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