Commit | Line | Data |
---|---|---|
799e6b82 | 1 | /* |
42a118aa RE |
2 | * Copyright (c) 1980 Regents of the University of California. |
3 | * All rights reserved. The Berkeley software License Agreement | |
4 | * specifies the terms and conditions for redistribution. | |
5 | * | |
6 | * @(#)trpfpe_.c 5.1 %G% | |
7 | */ | |
799e6b82 DW |
8 | * |
9 | * Fortran floating-point error handler | |
10 | * | |
11 | * Synopsis: | |
12 | * call trpfpe (n, retval) | |
13 | * causes floating point faults to be trapped, with the | |
14 | * first 'n' errors getting a message printed. | |
15 | * 'retval' is put in place of the bad result. | |
16 | * k = fpecnt() | |
17 | * causes 'k' to get the number of errors since the | |
18 | * last call to trpfpe(). | |
19 | * | |
20 | * common /fpeflt/ fpflag | |
21 | * logical fpflag | |
22 | * fpflag will become .true. on faults | |
23 | * | |
24 | * David Wasley, UCBerkeley, June 1983. | |
25 | */ | |
26 | ||
27 | ||
28 | #include <stdio.h> | |
29 | #include <signal.h> | |
30 | #include "opcodes.h" | |
31 | #include "operand.h" | |
32 | #include "../libI77/fiodefs.h" | |
33 | ||
34 | #define SIG_VAL int (*)() | |
35 | ||
36 | #if vax /* only works on VAXen */ | |
37 | ||
38 | struct arglist { /* what AP points to */ | |
39 | long al_numarg; /* only true in CALLS format */ | |
40 | long al_arg[256]; | |
41 | }; | |
42 | ||
43 | struct cframe { /* VAX call frame */ | |
44 | long cf_handler; | |
45 | unsigned short cf_psw; | |
46 | unsigned short cf_mask; | |
47 | struct arglist *cf_ap; | |
48 | struct cframe *cf_fp; | |
49 | char *cf_pc; | |
50 | }; | |
51 | ||
52 | /* | |
53 | * bits in the PSW | |
54 | */ | |
55 | #define PSW_V 0x2 | |
56 | #define PSW_FU 0x40 | |
57 | #define PSW_IV 0x20 | |
58 | ||
59 | /* | |
60 | * where the registers are stored as we see them in the handler | |
61 | */ | |
62 | struct reg0_6 { | |
63 | long reg[7]; | |
64 | }; | |
65 | ||
66 | struct reg7_11 { | |
67 | long reg[5]; | |
68 | }; | |
69 | ||
70 | #define iR0 reg0_6->reg[0] | |
71 | #define iR1 reg0_6->reg[1] | |
72 | #define iR2 reg0_6->reg[2] | |
73 | #define iR3 reg0_6->reg[3] | |
74 | #define iR4 reg0_6->reg[4] | |
75 | #define iR5 reg0_6->reg[5] | |
76 | #define iR6 reg0_6->reg[6] | |
77 | #define iR7 reg7_11->reg[0] | |
78 | #define iR8 reg7_11->reg[1] | |
79 | #define iR9 reg7_11->reg[2] | |
80 | #define iR10 reg7_11->reg[3] | |
81 | #define iR11 reg7_11->reg[4] | |
82 | ||
83 | union objects { /* for load/store */ | |
84 | char ua_byte; | |
85 | short ua_word; | |
86 | long ua_long; | |
87 | float ua_float; | |
88 | double ua_double; | |
89 | union objects *ua_anything; | |
90 | }; | |
91 | ||
92 | typedef union objects anything; | |
93 | enum object_type { BYTE, WORD, LONG, FLOAT, QUAD, DOUBLE, UNKNOWN }; | |
94 | ||
95 | \f | |
96 | /* | |
97 | * assembly language assist | |
98 | * There are some things you just can't do in C | |
99 | */ | |
100 | asm(".text"); | |
101 | ||
102 | struct cframe *myfp(); | |
103 | asm("_myfp: .word 0x0"); | |
104 | asm("movl 12(fp),r0"); | |
105 | asm("ret"); | |
106 | ||
107 | struct arglist *myap(); | |
108 | asm("_myap: .word 0x0"); | |
109 | asm("movl 8(fp),r0"); | |
110 | asm("ret"); | |
111 | ||
112 | char *mysp(); | |
113 | asm("_mysp: .word 0x0"); | |
114 | asm("extzv $30,$2,4(fp),r0"); | |
115 | asm("addl2 ap,r0"); /* SP in caller is AP+4 here + SPA bits! */ | |
116 | asm("addl2 $4,r0"); | |
117 | asm("ret"); | |
118 | ||
119 | char *mypc(); | |
120 | asm("_mypc: .word 0x0"); | |
121 | asm("movl 16(fp),r0"); | |
122 | asm("ret"); | |
123 | ||
124 | asm(".data"); | |
125 | ||
126 | \f | |
127 | /* | |
128 | * Where interrupted objects are | |
129 | */ | |
130 | static struct cframe **ifp; /* addr of saved FP */ | |
131 | static struct arglist **iap; /* addr of saved AP */ | |
132 | static char *isp; /* value of interrupted SP */ | |
133 | static char **ipc; /* addr of saved PC */ | |
134 | static struct reg0_6 *reg0_6;/* registers 0-6 are saved on the exception */ | |
135 | static struct reg7_11 *reg7_11;/* we save 7-11 by our entry mask */ | |
136 | static anything *result_addr; /* where the dummy result goes */ | |
137 | static enum object_type result_type; /* what kind of object it is */ | |
138 | ||
139 | /* | |
140 | * some globals | |
141 | */ | |
142 | static union { | |
143 | long rv_long[2]; | |
144 | float rv_float; | |
145 | double rv_double; | |
146 | } retval; /* the user specified dummy result */ | |
147 | static int max_messages = 1; /* the user can tell us */ | |
148 | static int fpe_count = 0; /* how bad is it ? */ | |
149 | long fpeflt_ = 0; /* fortran "common /fpeflt/ flag" */ | |
150 | static int (*sigfpe_dfl)() = SIG_DFL; /* if we can't fix it ... */ | |
151 | ||
152 | /* | |
153 | * The fortran unit control table | |
154 | */ | |
155 | extern unit units[]; | |
156 | ||
157 | /* | |
158 | * Fortran message table is in main | |
159 | */ | |
160 | struct msgtbl { | |
161 | char *mesg; | |
162 | int dummy; | |
163 | }; | |
164 | extern struct msgtbl act_fpe[]; | |
165 | ||
166 | \f | |
167 | /* | |
168 | * Get the address of the (saved) next operand & update saved PC. | |
169 | * The major purpose of this is to determine where to store the result. | |
170 | * There is one case we can't deal with: -(SP) or (SP)+ | |
171 | * since we can't change the size of the stack. | |
172 | * Let's just hope compilers don't generate that for results. | |
173 | */ | |
174 | ||
175 | anything * | |
176 | get_operand (oper_size) | |
177 | int oper_size; /* size of operand we expect */ | |
178 | { | |
179 | register int regnum; | |
180 | register int operand_code; | |
181 | int index; | |
182 | anything *oper_addr; | |
183 | anything *reg_addr; | |
184 | ||
185 | regnum = (**ipc & 0xf); | |
186 | if (regnum == PC) | |
187 | operand_code = (*(*ipc)++ & 0xff); | |
188 | else | |
189 | operand_code = (*(*ipc)++ & 0xf0); | |
190 | if (regnum <= R6) | |
191 | reg_addr = (anything *)®0_6->reg[regnum]; | |
192 | else if (regnum <= R11) | |
193 | reg_addr = (anything *)®7_11->reg[regnum]; | |
194 | else if (regnum == AP) | |
195 | reg_addr = (anything *)iap; | |
196 | else if (regnum == FP) | |
197 | reg_addr = (anything *)ifp; | |
198 | else if (regnum == SP) | |
199 | reg_addr = (anything *)&isp; /* We saved this ourselves */ | |
200 | else if (regnum == PC) | |
201 | reg_addr = (anything *)ipc; | |
202 | ||
203 | ||
204 | switch (operand_code) | |
205 | { | |
206 | case IMMEDIATE: | |
207 | oper_addr = (anything *)(*ipc); | |
208 | *ipc += oper_size; | |
209 | return(oper_addr); | |
210 | ||
211 | case ABSOLUTE: | |
212 | oper_addr = (anything *)(**ipc); | |
213 | *ipc += sizeof (anything *); | |
214 | return(oper_addr); | |
215 | ||
216 | case LITERAL0: | |
217 | case LITERAL1: | |
218 | case LITERAL2: | |
219 | case LITERAL3: | |
220 | /* we don't care about the address of these */ | |
221 | return((anything *)0); | |
222 | ||
223 | case INDEXED: | |
224 | index = reg_addr->ua_long * oper_size; | |
225 | oper_addr = (anything *)(get_operand(sizeof (long))->ua_long + index); | |
226 | return(oper_addr); | |
227 | ||
228 | case REGISTER: | |
229 | return(reg_addr); | |
230 | ||
231 | case REGDEFERED: | |
232 | return(reg_addr->ua_anything); | |
233 | ||
234 | case AUTODEC: | |
235 | if (regnum == SP) | |
236 | { | |
237 | fprintf(stderr, "trp: can't fix -(SP) operand\n"); | |
238 | exit(1); | |
239 | } | |
240 | reg_addr->ua_long -= oper_size; | |
241 | oper_addr = reg_addr->ua_anything; | |
242 | return(oper_addr); | |
243 | ||
244 | case AUTOINC: | |
245 | if (regnum == SP) | |
246 | { | |
247 | fprintf(stderr, "trp: can't fix (SP)+ operand\n"); | |
248 | exit(1); | |
249 | } | |
250 | oper_addr = reg_addr->ua_anything; | |
251 | reg_addr->ua_long += oper_size; | |
252 | return(oper_addr); | |
253 | ||
254 | case AUTOINCDEF: | |
255 | if (regnum == SP) | |
256 | { | |
257 | fprintf(stderr, "trp: can't fix @(SP)+ operand\n"); | |
258 | exit(1); | |
259 | } | |
260 | oper_addr = (reg_addr->ua_anything)->ua_anything; | |
261 | reg_addr->ua_long += sizeof (anything *); | |
262 | return(oper_addr); | |
263 | ||
264 | case BYTEDISP: | |
265 | case BYTEREL: | |
b9f2a0ee DW |
266 | index = ((anything *)(*ipc))->ua_byte; |
267 | *ipc += sizeof (char); /* do it now in case reg==PC */ | |
268 | oper_addr = (anything *)(index + reg_addr->ua_long); | |
799e6b82 DW |
269 | return(oper_addr); |
270 | ||
271 | case BYTEDISPDEF: | |
272 | case BYTERELDEF: | |
b9f2a0ee DW |
273 | index = ((anything *)(*ipc))->ua_byte; |
274 | *ipc += sizeof (char); /* do it now in case reg==PC */ | |
275 | oper_addr = (anything *)(index + reg_addr->ua_long); | |
799e6b82 | 276 | oper_addr = oper_addr->ua_anything; |
799e6b82 DW |
277 | return(oper_addr); |
278 | ||
279 | case WORDDISP: | |
280 | case WORDREL: | |
b9f2a0ee DW |
281 | index = ((anything *)(*ipc))->ua_word; |
282 | *ipc += sizeof (short); /* do it now in case reg==PC */ | |
283 | oper_addr = (anything *)(index + reg_addr->ua_long); | |
799e6b82 DW |
284 | return(oper_addr); |
285 | ||
286 | case WORDDISPDEF: | |
287 | case WORDRELDEF: | |
b9f2a0ee DW |
288 | index = ((anything *)(*ipc))->ua_word; |
289 | *ipc += sizeof (short); /* do it now in case reg==PC */ | |
290 | oper_addr = (anything *)(index + reg_addr->ua_long); | |
799e6b82 | 291 | oper_addr = oper_addr->ua_anything; |
799e6b82 DW |
292 | return(oper_addr); |
293 | ||
294 | case LONGDISP: | |
295 | case LONGREL: | |
b9f2a0ee DW |
296 | index = ((anything *)(*ipc))->ua_long; |
297 | *ipc += sizeof (long); /* do it now in case reg==PC */ | |
298 | oper_addr = (anything *)(index + reg_addr->ua_long); | |
799e6b82 DW |
299 | return(oper_addr); |
300 | ||
301 | case LONGDISPDEF: | |
302 | case LONGRELDEF: | |
b9f2a0ee DW |
303 | index = ((anything *)(*ipc))->ua_long; |
304 | *ipc += sizeof (long); /* do it now in case reg==PC */ | |
305 | oper_addr = (anything *)(index + reg_addr->ua_long); | |
799e6b82 | 306 | oper_addr = oper_addr->ua_anything; |
799e6b82 DW |
307 | return(oper_addr); |
308 | ||
309 | /* NOTREACHED */ | |
310 | } | |
311 | } | |
312 | \f | |
313 | /* | |
314 | * Trap & repair floating exceptions so that a program may proceed. | |
315 | * There is no notion of "correctness" here; just the ability to continue. | |
316 | * | |
317 | * The on_fpe() routine first checks the type code to see if the | |
318 | * exception is repairable. If so, it checks the opcode to see if | |
319 | * it is one that it knows. If this is true, it then simulates the | |
320 | * VAX cpu in retrieving operands in order to increment iPC correctly. | |
321 | * It notes where the result of the operation would have been stored | |
322 | * and substitutes a previously supplied value. | |
323 | */ | |
324 | ||
325 | #ifdef OLD_BSD | |
326 | on_fpe(signo, code, myaddr, pc, ps) | |
327 | int signo, code, ps; | |
328 | char *myaddr, *pc; | |
329 | #else | |
330 | on_fpe(signo, code, sc, grbg) | |
331 | int signo, code; | |
332 | struct sigcontext *sc; | |
333 | #endif | |
334 | { | |
335 | /* | |
336 | * There must be at least 5 register variables here | |
337 | * so our entry mask will save R11-R7. | |
338 | */ | |
339 | register long *stk; | |
340 | register long *sp; | |
341 | register struct arglist *ap; | |
342 | register struct cframe *fp; | |
343 | register FILE *ef; | |
344 | ||
345 | ef = units[STDERR].ufd; /* fortran error stream */ | |
346 | ||
347 | switch (code) | |
348 | { | |
349 | case FPE_INTOVF_TRAP: /* integer overflow */ | |
350 | case FPE_INTDIV_TRAP: /* integer divide by zero */ | |
351 | case FPE_FLTOVF_TRAP: /* floating overflow */ | |
352 | case FPE_FLTDIV_TRAP: /* floating/decimal divide by zero */ | |
353 | case FPE_FLTUND_TRAP: /* floating underflow */ | |
354 | case FPE_DECOVF_TRAP: /* decimal overflow */ | |
355 | case FPE_SUBRNG_TRAP: /* subscript out of range */ | |
356 | default: | |
357 | cant_fix: | |
358 | if (sigfpe_dfl > (SIG_VAL)7) /* user specified */ | |
359 | #ifdef OLD_BSD | |
360 | return((*sigfpe_dfl)(signo, code, myaddr, pc, ps)); | |
361 | #else | |
362 | return((*sigfpe_dfl)(signo, code, sc, grbg)); | |
363 | #endif | |
364 | else | |
365 | #ifdef OLD_BSD | |
366 | sigdie(signo, code, myaddr, pc, ps); | |
367 | #else | |
368 | sigdie(signo, code, sc, grbg); | |
369 | #endif | |
370 | /* NOTREACHED */ | |
371 | ||
372 | case FPE_FLTOVF_FAULT: /* floating overflow fault */ | |
373 | case FPE_FLTDIV_FAULT: /* divide by zero floating fault */ | |
374 | case FPE_FLTUND_FAULT: /* floating underflow fault */ | |
375 | if (++fpe_count <= max_messages) { | |
376 | fprintf(ef, "trpfpe: %s", | |
377 | act_fpe[code-1].mesg); | |
378 | if (fpe_count == max_messages) | |
379 | fprintf(ef, ": No more messages will be printed.\n"); | |
380 | else | |
381 | fputc('\n', ef); | |
382 | } | |
383 | fpeflt_ = -1; | |
384 | break; | |
385 | } | |
386 | ||
387 | ap = myap(); /* my arglist pointer */ | |
388 | fp = myfp(); /* my frame pointer */ | |
389 | ifp = &(fp->cf_fp)->cf_fp; /* user's stored in next frame back */ | |
390 | iap = &(fp->cf_fp)->cf_ap; | |
391 | /* | |
392 | * these are likely to be system dependent | |
393 | */ | |
394 | reg0_6 = (struct reg0_6 *)((char *)fp->cf_fp + sizeof (struct cframe)); | |
395 | reg7_11 = (struct reg7_11 *)((char *)fp->cf_fp - sizeof (struct reg7_11)); | |
396 | ||
397 | #ifdef OLD_BSD | |
398 | ipc = &pc; | |
399 | isp = (char *)&ap->al_arg[ap->al_numarg + 2]; /* assumes 2 dummys */ | |
400 | ps &= ~(PSW_V|PSW_FU); | |
401 | #else | |
402 | ipc = (char **)&sc->sc_pc; | |
09f50985 | 403 | isp = (char *)sc + sizeof (struct sigcontext); |
799e6b82 DW |
404 | sc->sc_ps &= ~(PSW_V|PSW_FU); |
405 | #endif | |
406 | ||
407 | ||
408 | switch (*(*ipc)++) | |
409 | { | |
410 | case ADDD3: | |
411 | case DIVD3: | |
412 | case MULD3: | |
413 | case SUBD3: | |
414 | (void) get_operand(sizeof (double)); | |
415 | /* intentional fall-thru */ | |
416 | ||
417 | case ADDD2: | |
418 | case DIVD2: | |
419 | case MULD2: | |
420 | case SUBD2: | |
421 | case MNEGD: | |
422 | case MOVD: | |
423 | (void) get_operand(sizeof (double)); | |
424 | result_addr = get_operand(sizeof (double)); | |
425 | result_type = DOUBLE; | |
426 | break; | |
427 | ||
428 | case ADDF3: | |
429 | case DIVF3: | |
430 | case MULF3: | |
431 | case SUBF3: | |
432 | (void) get_operand(sizeof (float)); | |
433 | /* intentional fall-thru */ | |
434 | ||
435 | case ADDF2: | |
436 | case DIVF2: | |
437 | case MULF2: | |
438 | case SUBF2: | |
439 | case MNEGF: | |
440 | case MOVF: | |
441 | (void) get_operand(sizeof (float)); | |
442 | result_addr = get_operand(sizeof (float)); | |
443 | result_type = FLOAT; | |
444 | break; | |
445 | ||
446 | case CVTDF: | |
447 | (void) get_operand(sizeof (double)); | |
448 | result_addr = get_operand(sizeof (float)); | |
449 | result_type = FLOAT; | |
450 | break; | |
451 | ||
452 | case CVTFD: | |
453 | (void) get_operand(sizeof (float)); | |
454 | result_addr = get_operand(sizeof (double)); | |
455 | result_type = DOUBLE; | |
456 | break; | |
457 | ||
458 | case EMODF: | |
459 | case EMODD: | |
460 | fprintf(ef, "trpfpe: can't fix emod yet\n"); | |
461 | goto cant_fix; | |
462 | ||
463 | case POLYF: | |
464 | case POLYD: | |
465 | fprintf(ef, "trpfpe: can't fix poly yet\n"); | |
466 | goto cant_fix; | |
467 | ||
468 | case ACBD: | |
469 | case ACBF: | |
470 | case CMPD: | |
471 | case CMPF: | |
472 | case TSTD: | |
473 | case TSTF: | |
474 | case CVTDB: | |
475 | case CVTDL: | |
476 | case CVTDW: | |
477 | case CVTFB: | |
478 | case CVTFL: | |
479 | case CVTFW: | |
480 | case CVTRDL: | |
481 | case CVTRFL: | |
482 | /* These can generate only reserved operand faults */ | |
483 | /* They are shown here for completeness */ | |
484 | ||
485 | default: | |
486 | fprintf(stderr, "trp: opcode 0x%02x unknown\n", | |
487 | *(--(*ipc)) & 0xff); | |
488 | goto cant_fix; | |
489 | /* NOTREACHED */ | |
490 | } | |
491 | ||
492 | if (result_type == FLOAT) | |
493 | result_addr->ua_float = retval.rv_float; | |
494 | else | |
495 | { | |
496 | if (result_addr == (anything *)&iR6) | |
497 | { /* | |
498 | * special case - the R6/R7 pair is stored apart | |
499 | */ | |
500 | result_addr->ua_long = retval.rv_long[0]; | |
501 | ((anything *)&iR7)->ua_long = retval.rv_long[1]; | |
502 | } | |
503 | else | |
504 | result_addr->ua_double = retval.rv_double; | |
505 | } | |
506 | signal(SIGFPE, on_fpe); | |
507 | } | |
508 | #endif vax | |
509 | ||
510 | trpfpe_ (count, rval) | |
511 | long *count; /* how many to announce */ | |
512 | double *rval; /* dummy return value */ | |
513 | { | |
514 | #if vax | |
515 | max_messages = *count; | |
516 | retval.rv_double = *rval; | |
517 | sigfpe_dfl = signal(SIGFPE, on_fpe); | |
518 | fpe_count = 0; | |
519 | #endif | |
520 | } | |
521 | ||
522 | long | |
523 | fpecnt_ () | |
524 | { | |
525 | #if vax | |
526 | return (fpe_count); | |
527 | #else | |
528 | return (0L); | |
529 | #endif | |
530 | } | |
531 |