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 '((stw (reg 2) (displacement (reg 1) 0))))) 76 77(compiletime (put 'getstack 'opencode '((addi (reg 1) (reg st) 0)))) 78(compiletime (de ZIBAnyregMemory (reg source offset) 79 (prog (aReg cadrsource) 80 (setq source (resolveoperand reg source)) 81 (setq offset (resolveoperand reg offset)) 82 (setq aReg (if (and (displacementp source) 83 (member (setq cadrsource (cadr source)) 84 *nextreglist*)) 85 cadrsource (nexttempreg))) 86 (push `(*move ,source ,aReg) Resultingcode*) 87 (unless (eq 0 offset) (push `(*wplus2 ,aReg ,offset) Resultingcode*)) 88%%%% (push `(*mkitem ,areg (quote 4)) Resultingcode*) 89%%%% (push `(*field ,areg ,areg 5 27) Resultingcode*) 90 (return `(displacement ,areg 0))))) 91 92 93(de signal-done () 94 (lisprpv1)) 95 96(fluid '(save-heaplast save-bndstkptr)) 97 98(de lisprpv(num val) % this one is called from the system in case of a trap 99 % we have to make a longjump (in sigset) because the 100 % signal context could not be found 101 (prog (mess sta) 102 (setq *bruch* 0) 103 (setq save-bndstkptr bndstkptr) % have to save the registers across longjump 104 (setq save-heaplast heaplast) 105 (setq ibmrs-signumber num) 106 (setq ibmrs-sigpc (getmem (wplus2 val 24))) 107 (return (psl_sigset (wgetv symfnc (id2int 'signalhaendler)) (getstack))) 108)) 109 110(de lisprpv1() 111 112 (setq sta (getstack)) 113 (setq bndstkptr save-bndstkptr) % have to restore the registers after longjump 114 (setq heaplast save-heaplast) 115 116 (smalldump) 117 (initializeinterrupts) 118 (setq mess (atsoc ibmrs-signumber '((1 . "Hangup") 119 (2 . "Interrupt") 120 (3 . "Quit") 121 (4 . "Illegal Instruction") 122 (5 . "Trace Trap") 123 (6 . "IOT Instruction") 124 (7 . "EMT Instruction") 125 (8 . "Floating Point Exception") 126 (10 . "Bus Error") 127 (11 . "Memory Fault") 128 (12 . "Bad Args to System Call") 129 (13 . "Write on Pipe With None to Read") 130 (14 . "Alarm Clock") 131 (15 . "Software termination signal") ))) 132% (when (eq ibmrs-signumber 8) 133% (cond ((eq ibmrs-sigcode 16#c8) 134% (setq mess '( 0 . "Floating Point divide by zero"))) 135% ((eq ibmrs-sigcode 16#d4) 136% (setq mess '( 0 . "Floating Point overflow"))) 137% ((eq ibmrs-sigcode 16#cc) 138% (setq mess '( 0 . "Floating Point underflow"))))) 139 (setq mess (if mess (cdr mess) 140 (bldmsg " Unknown signal type %d" ibmrs-signumber))) 141 (build-trap-message mess ibmrs-sigpc) 142 (setq ibmrs-sigaddr 0 ibmrs-sigcp 0 ibmrs-sigpc 0) % for gc 143 (return (stderror)))) 144 145(de smalldump() 146 (when *dump 147 (console-print-string "*** UNEXPECTED INTERRUPT ***") 148 (console-newline) 149 (console-print-string "*** System signal number: 16#") 150 (unixputn ibmrs-signumber) 151 (console-print-string " , signal code: 16#") 152 (unixputn ibmrs-sigcode) 153 (console-newline) 154 (console-print-string "*** signal pc: 16#") 155 (unixputn ibmrs-sigpc) 156 (console-print-string " , signal stack: 16#") 157 (unixputn ibmrs-sigaddr) 158 (console-print-string " , context: 16#") 159 (unixputn ibmrs-sigcp) 160 (console-newline) 161 (setq ibmrs-sigaddr 0 ibmrs-sigcp 0) % for gc 162 (console-print-string "*** Registers 0-7 : ") 163 (unixputn (wgetv ibmrs-dumparray* 0)) (console-print-string " ") 164 (unixputn (wgetv ibmrs-dumparray* 1)) (console-print-string " ") 165 (unixputn (wgetv ibmrs-dumparray* 2)) (console-print-string " ") 166 (unixputn (wgetv ibmrs-dumparray* 3)) (console-print-string " ") 167 (unixputn (wgetv ibmrs-dumparray* 4)) (console-print-string " ") 168 (unixputn (wgetv ibmrs-dumparray* 5)) (console-print-string " ") 169 (unixputn (wgetv ibmrs-dumparray* 6)) (console-print-string " ") 170 (unixputn (wgetv ibmrs-dumparray* 7)) (console-print-string " ") 171 (console-newline) 172 (console-print-string "*** Registers 8-15: ") 173 (unixputn (wgetv ibmrs-dumparray* 8)) (console-print-string " ") 174 (unixputn (wgetv ibmrs-dumparray* 9)) (console-print-string " ") 175 (unixputn (wgetv ibmrs-dumparray* 10)) (console-print-string " ") 176 (unixputn (wgetv ibmrs-dumparray* 11)) (console-print-string " ") 177 (unixputn (wgetv ibmrs-dumparray* 12)) (console-print-string " ") 178 (unixputn (wgetv ibmrs-dumparray* 13)) (console-print-string " ") 179 (unixputn (wgetv ibmrs-dumparray* 14)) (console-print-string " ") 180 (unixputn (wgetv ibmrs-dumparray* 15)) (console-print-string " ") 181 (console-newline) 182 (console-print-string "*** Registers 16-23: ") 183 (unixputn (wgetv ibmrs-dumparray* 16)) (console-print-string " ") 184 (unixputn (wgetv ibmrs-dumparray* 17)) (console-print-string " ") 185 (unixputn (wgetv ibmrs-dumparray* 18)) (console-print-string " ") 186 (unixputn (wgetv ibmrs-dumparray* 19)) (console-print-string " ") 187 (unixputn (wgetv ibmrs-dumparray* 20)) (console-print-string " ") 188 (unixputn (wgetv ibmrs-dumparray* 21)) (console-print-string " ") 189 (unixputn (wgetv ibmrs-dumparray* 22)) (console-print-string " ") 190 (unixputn (wgetv ibmrs-dumparray* 23)) (console-print-string " ") 191 (console-newline) 192 (console-print-string "*** Registers 24-31: ") 193 (unixputn (wgetv ibmrs-dumparray* 24)) (console-print-string " ") 194 (unixputn (wgetv ibmrs-dumparray* 25)) (console-print-string " ") 195 (unixputn (wgetv ibmrs-dumparray* 26)) (console-print-string " ") 196 (unixputn (wgetv ibmrs-dumparray* 27)) (console-print-string " ") 197 (unixputn (wgetv ibmrs-dumparray* 28)) (console-print-string " ") 198 (unixputn (wgetv ibmrs-dumparray* 29)) (console-print-string " ") 199 (unixputn (wgetv ibmrs-dumparray* 30)) (console-print-string " ") 200 (unixputn (wgetv ibmrs-dumparray* 31)) (console-print-string " ") 201 (console-newline) 202 (console-print-string "*** Sigcontext : ") 203 (unixputn (wgetv ibmrs-dumparray* 50)) (console-print-string " ") 204 (unixputn (wgetv ibmrs-dumparray* 51)) (console-print-string " ") 205 (unixputn (wgetv ibmrs-dumparray* 52)) (console-print-string " ") 206 (unixputn (wgetv ibmrs-dumparray* 53)) (console-print-string " ") 207 (unixputn (wgetv ibmrs-dumparray* 54)) (console-print-string " ") 208 (unixputn (wgetv ibmrs-dumparray* 55)) (console-print-string " ") 209 (unixputn (wgetv ibmrs-dumparray* 56)) (console-print-string " ") 210 (unixputn (wgetv ibmrs-dumparray* 57)) (console-print-string " ") 211 (console-newline) 212 (console-newline) 213)) 214 215(compiletime (flag '(x-code-address-to-symbol) 'internalfunction)) 216 217(de build-trap-message (trap-type trap-addr) 218 (let (extra-info) 219 (setf extra-info (bldmsg "%w%w" " in " 220 (x-code-address-to-symbol (inf trap-addr)))) 221 (bldmsg "%w%w" trap-type extra-info))) 222 223(fluid '(code-address* closest-address* closest-symbol*)) 224 225(de x-code-address-to-symbol (code-address*) 226 (let ((closest-symbol* ()) (closest-address* 0)) 227 (mapobl #'(lambda (symbol) 228 (when (fcodep symbol) 229 (let ((address (inf (getfcodepointer symbol)))) 230 (when (and (ileq address code-address*) 231 (igreaterp address closest-address*)) 232 (setq closest-address* address) 233 (setq closest-symbol* symbol)))))) 234 closest-symbol*)) 235 236(de code-address-to-symbol (ad) (x-code-address-to-symbol ad)) 237