1 /*-
2 * Copyright (c) 1980 The Regents of the University of California.
3 * All rights reserved.
4 *
5 * %sccs.include.proprietary.c%
6 */
7
8 #ifndef lint
9 static char sccsid[] = "@(#)trpfpe_.c 5.7 (Berkeley) 04/12/91";
10 #endif /* not lint */
11
12 /* #define OLD_BSD if you're running < 4.2 bsd */
13
14 /*
15 * Fortran floating-point error handler
16 *
17 * Synopsis:
18 * call trpfpe (n, retval)
19 * causes floating point faults to be trapped, with the
20 * first 'n' errors getting a message printed.
21 * 'retval' is put in place of the bad result.
22 * k = fpecnt()
23 * causes 'k' to get the number of errors since the
24 * last call to trpfpe().
25 *
26 * common /fpeflt/ fpflag
27 * logical fpflag
28 * fpflag will become .true. on faults
29 *
30 * David Wasley, UCBerkeley, June 1983.
31 */
32
33
34 #include <stdio.h>
35 #include <sys/signal.h>
36 #include "../libI77/fiodefs.h"
37
38 #define SIG_VAL void (*)()
39
40 #ifdef vax
41 #include "opcodes.h"
42 #include "operand.h"
43
44 struct arglist { /* what AP points to */
45 long al_numarg; /* only true in CALLS format */
46 long al_arg[256];
47 };
48
49 struct cframe { /* VAX call frame */
50 long cf_handler;
51 unsigned short cf_psw;
52 unsigned short cf_mask;
53 struct arglist *cf_ap;
54 struct cframe *cf_fp;
55 char *cf_pc;
56 };
57
58 /*
59 * bits in the PSW
60 */
61 #define PSW_V 0x2
62 #define PSW_FU 0x40
63 #define PSW_IV 0x20
64
65 /*
66 * where the registers are stored as we see them in the handler
67 */
68 struct reg0_6 {
69 long reg[7];
70 };
71
72 struct reg7_11 {
73 long reg[5];
74 };
75
76 #define iR0 reg0_6->reg[0]
77 #define iR1 reg0_6->reg[1]
78 #define iR2 reg0_6->reg[2]
79 #define iR3 reg0_6->reg[3]
80 #define iR4 reg0_6->reg[4]
81 #define iR5 reg0_6->reg[5]
82 #define iR6 reg0_6->reg[6]
83 #define iR7 reg7_11->reg[0]
84 #define iR8 reg7_11->reg[1]
85 #define iR9 reg7_11->reg[2]
86 #define iR10 reg7_11->reg[3]
87 #define iR11 reg7_11->reg[4]
88
89 union objects { /* for load/store */
90 char ua_byte;
91 short ua_word;
92 long ua_long;
93 float ua_float;
94 double ua_double;
95 union objects *ua_anything;
96 };
97
98 typedef union objects anything;
99 enum object_type { BYTE, WORD, LONG, FLOAT, QUAD, DOUBLE, UNKNOWN };
100
101
102 /*
103 * assembly language assist
104 * There are some things you just can't do in C
105 */
106 asm(".text");
107
108 struct cframe *myfp();
109 asm("_myfp: .word 0x0");
110 asm("movl 12(fp),r0");
111 asm("ret");
112
113 struct arglist *myap();
114 asm("_myap: .word 0x0");
115 asm("movl 8(fp),r0");
116 asm("ret");
117
118 char *mysp();
119 asm("_mysp: .word 0x0");
120 asm("extzv $30,$2,4(fp),r0");
121 asm("addl2 ap,r0"); /* SP in caller is AP+4 here + SPA bits! */
122 asm("addl2 $4,r0");
123 asm("ret");
124
125 char *mypc();
126 asm("_mypc: .word 0x0");
127 asm("movl 16(fp),r0");
128 asm("ret");
129
130 asm(".data");
131
132
133 /*
134 * Where interrupted objects are
135 */
136 static struct cframe **ifp; /* addr of saved FP */
137 static struct arglist **iap; /* addr of saved AP */
138 static char *isp; /* value of interrupted SP */
139 static char **ipc; /* addr of saved PC */
140 static struct reg0_6 *reg0_6;/* registers 0-6 are saved on the exception */
141 static struct reg7_11 *reg7_11;/* we save 7-11 by our entry mask */
142 static anything *result_addr; /* where the dummy result goes */
143 static enum object_type result_type; /* what kind of object it is */
144
145 /*
146 * some globals
147 */
148 static union {
149 long rv_long[2];
150 float rv_float;
151 double rv_double;
152 } retval; /* the user specified dummy result */
153 static int max_messages = 1; /* the user can tell us */
154 static int fpe_count = 0; /* how bad is it ? */
155 long fpeflt_ = 0; /* fortran "common /fpeflt/ flag" */
156 static sig_t sigfpe_dfl = SIG_DFL; /* if we can't fix it ... */
157
158 /*
159 * The fortran unit control table
160 */
161 extern unit units[];
162
163 /*
164 * Fortran message table is in main
165 */
166 struct msgtbl {
167 char *mesg;
168 int dummy;
169 };
170 extern struct msgtbl act_fpe[];
171
172
173 /*
174 * Get the address of the (saved) next operand & update saved PC.
175 * The major purpose of this is to determine where to store the result.
176 * There is one case we can't deal with: -(SP) or (SP)+
177 * since we can't change the size of the stack.
178 * Let's just hope compilers don't generate that for results.
179 */
180
181 anything *
get_operand(oper_size)182 get_operand (oper_size)
183 int oper_size; /* size of operand we expect */
184 {
185 register int regnum;
186 register int operand_code;
187 int index;
188 anything *oper_addr;
189 anything *reg_addr;
190
191 regnum = (**ipc & 0xf);
192 if (regnum == PC)
193 operand_code = (*(*ipc)++ & 0xff);
194 else
195 operand_code = (*(*ipc)++ & 0xf0);
196 if (regnum <= R6)
197 reg_addr = (anything *)®0_6->reg[regnum];
198 else if (regnum <= R11)
199 reg_addr = (anything *)®7_11->reg[regnum];
200 else if (regnum == AP)
201 reg_addr = (anything *)iap;
202 else if (regnum == FP)
203 reg_addr = (anything *)ifp;
204 else if (regnum == SP)
205 reg_addr = (anything *)&isp; /* We saved this ourselves */
206 else if (regnum == PC)
207 reg_addr = (anything *)ipc;
208
209
210 switch (operand_code)
211 {
212 case IMMEDIATE:
213 oper_addr = (anything *)(*ipc);
214 *ipc += oper_size;
215 return(oper_addr);
216
217 case ABSOLUTE:
218 oper_addr = (anything *)(**ipc);
219 *ipc += sizeof (anything *);
220 return(oper_addr);
221
222 case LITERAL0:
223 case LITERAL1:
224 case LITERAL2:
225 case LITERAL3:
226 /* we don't care about the address of these */
227 return((anything *)0);
228
229 case INDEXED:
230 index = reg_addr->ua_long * oper_size;
231 oper_addr = (anything *)(get_operand(sizeof (long))->ua_long + index);
232 return(oper_addr);
233
234 case REGISTER:
235 return(reg_addr);
236
237 case REGDEFERED:
238 return(reg_addr->ua_anything);
239
240 case AUTODEC:
241 if (regnum == SP)
242 {
243 fprintf(stderr, "trp: can't fix -(SP) operand\n");
244 exit(1);
245 }
246 reg_addr->ua_long -= oper_size;
247 oper_addr = reg_addr->ua_anything;
248 return(oper_addr);
249
250 case AUTOINC:
251 if (regnum == SP)
252 {
253 fprintf(stderr, "trp: can't fix (SP)+ operand\n");
254 exit(1);
255 }
256 oper_addr = reg_addr->ua_anything;
257 reg_addr->ua_long += oper_size;
258 return(oper_addr);
259
260 case AUTOINCDEF:
261 if (regnum == SP)
262 {
263 fprintf(stderr, "trp: can't fix @(SP)+ operand\n");
264 exit(1);
265 }
266 oper_addr = (reg_addr->ua_anything)->ua_anything;
267 reg_addr->ua_long += sizeof (anything *);
268 return(oper_addr);
269
270 case BYTEDISP:
271 case BYTEREL:
272 index = ((anything *)(*ipc))->ua_byte;
273 *ipc += sizeof (char); /* do it now in case reg==PC */
274 oper_addr = (anything *)(index + reg_addr->ua_long);
275 return(oper_addr);
276
277 case BYTEDISPDEF:
278 case BYTERELDEF:
279 index = ((anything *)(*ipc))->ua_byte;
280 *ipc += sizeof (char); /* do it now in case reg==PC */
281 oper_addr = (anything *)(index + reg_addr->ua_long);
282 oper_addr = oper_addr->ua_anything;
283 return(oper_addr);
284
285 case WORDDISP:
286 case WORDREL:
287 index = ((anything *)(*ipc))->ua_word;
288 *ipc += sizeof (short); /* do it now in case reg==PC */
289 oper_addr = (anything *)(index + reg_addr->ua_long);
290 return(oper_addr);
291
292 case WORDDISPDEF:
293 case WORDRELDEF:
294 index = ((anything *)(*ipc))->ua_word;
295 *ipc += sizeof (short); /* do it now in case reg==PC */
296 oper_addr = (anything *)(index + reg_addr->ua_long);
297 oper_addr = oper_addr->ua_anything;
298 return(oper_addr);
299
300 case LONGDISP:
301 case LONGREL:
302 index = ((anything *)(*ipc))->ua_long;
303 *ipc += sizeof (long); /* do it now in case reg==PC */
304 oper_addr = (anything *)(index + reg_addr->ua_long);
305 return(oper_addr);
306
307 case LONGDISPDEF:
308 case LONGRELDEF:
309 index = ((anything *)(*ipc))->ua_long;
310 *ipc += sizeof (long); /* do it now in case reg==PC */
311 oper_addr = (anything *)(index + reg_addr->ua_long);
312 oper_addr = oper_addr->ua_anything;
313 return(oper_addr);
314
315 /* NOTREACHED */
316 }
317 }
318
319 /*
320 * Trap & repair floating exceptions so that a program may proceed.
321 * There is no notion of "correctness" here; just the ability to continue.
322 *
323 * The on_fpe() routine first checks the type code to see if the
324 * exception is repairable. If so, it checks the opcode to see if
325 * it is one that it knows. If this is true, it then simulates the
326 * VAX cpu in retrieving operands in order to increment iPC correctly.
327 * It notes where the result of the operation would have been stored
328 * and substitutes a previously supplied value.
329 */
330
331 #ifdef OLD_BSD
on_fpe(signo,code,myaddr,pc,ps)332 on_fpe(signo, code, myaddr, pc, ps)
333 int signo, code, ps;
334 char *myaddr, *pc;
335 #else
336 void
337 on_fpe(signo, code, sc, grbg)
338 int signo, code;
339 struct sigcontext *sc;
340 #endif
341 {
342 /*
343 * There must be at least 5 register variables here
344 * so our entry mask will save R11-R7.
345 */
346 register long *stk;
347 register long *sp;
348 register struct arglist *ap;
349 register struct cframe *fp;
350 register FILE *ef;
351
352 ef = units[STDERR].ufd; /* fortran error stream */
353
354 switch (code)
355 {
356 case FPE_INTOVF_TRAP: /* integer overflow */
357 case FPE_INTDIV_TRAP: /* integer divide by zero */
358 case FPE_FLTOVF_TRAP: /* floating overflow */
359 case FPE_FLTDIV_TRAP: /* floating/decimal divide by zero */
360 case FPE_FLTUND_TRAP: /* floating underflow */
361 case FPE_DECOVF_TRAP: /* decimal overflow */
362 case FPE_SUBRNG_TRAP: /* subscript out of range */
363 default:
364 cant_fix:
365 if (sigfpe_dfl > (SIG_VAL)7) /* user specified */
366 #ifdef OLD_BSD
367 (*sigfpe_dfl)(signo, code, myaddr, pc, ps);
368 #else
369 (*sigfpe_dfl)(signo, code, sc, grbg);
370 #endif
371 else
372 #ifdef OLD_BSD
373 sigdie(signo, code, myaddr, pc, ps);
374 #else
375 sigdie(signo, code, sc, grbg);
376 #endif
377 /* NOTREACHED */
378
379 case FPE_FLTOVF_FAULT: /* floating overflow fault */
380 case FPE_FLTDIV_FAULT: /* divide by zero floating fault */
381 case FPE_FLTUND_FAULT: /* floating underflow fault */
382 if (++fpe_count <= max_messages) {
383 fprintf(ef, "trpfpe: %s",
384 act_fpe[code-1].mesg);
385 if (fpe_count == max_messages)
386 fprintf(ef, ": No more messages will be printed.\n");
387 else
388 fputc('\n', ef);
389 }
390 fpeflt_ = -1;
391 break;
392 }
393
394 ap = myap(); /* my arglist pointer */
395 fp = myfp(); /* my frame pointer */
396 ifp = &(fp->cf_fp)->cf_fp; /* user's stored in next frame back */
397 iap = &(fp->cf_fp)->cf_ap;
398 /*
399 * these are likely to be system dependent
400 */
401 reg0_6 = (struct reg0_6 *)((char *)fp->cf_fp + sizeof (struct cframe));
402 reg7_11 = (struct reg7_11 *)((char *)fp->cf_fp - sizeof (struct reg7_11));
403
404 #ifdef OLD_BSD
405 ipc = &pc;
406 isp = (char *)&ap->al_arg[ap->al_numarg + 2]; /* assumes 2 dummys */
407 ps &= ~(PSW_V|PSW_FU);
408 #else
409 ipc = (char **)&sc->sc_pc;
410 isp = (char *)sc + sizeof (struct sigcontext);
411 sc->sc_ps &= ~(PSW_V|PSW_FU);
412 #endif
413
414
415 switch (*(*ipc)++)
416 {
417 case ADDD3:
418 case DIVD3:
419 case MULD3:
420 case SUBD3:
421 (void) get_operand(sizeof (double));
422 /* intentional fall-thru */
423
424 case ADDD2:
425 case DIVD2:
426 case MULD2:
427 case SUBD2:
428 case MNEGD:
429 case MOVD:
430 (void) get_operand(sizeof (double));
431 result_addr = get_operand(sizeof (double));
432 result_type = DOUBLE;
433 break;
434
435 case ADDF3:
436 case DIVF3:
437 case MULF3:
438 case SUBF3:
439 (void) get_operand(sizeof (float));
440 /* intentional fall-thru */
441
442 case ADDF2:
443 case DIVF2:
444 case MULF2:
445 case SUBF2:
446 case MNEGF:
447 case MOVF:
448 (void) get_operand(sizeof (float));
449 result_addr = get_operand(sizeof (float));
450 result_type = FLOAT;
451 break;
452
453 case CVTDF:
454 (void) get_operand(sizeof (double));
455 result_addr = get_operand(sizeof (float));
456 result_type = FLOAT;
457 break;
458
459 case CVTFD:
460 (void) get_operand(sizeof (float));
461 result_addr = get_operand(sizeof (double));
462 result_type = DOUBLE;
463 break;
464
465 case EMODF:
466 case EMODD:
467 fprintf(ef, "trpfpe: can't fix emod yet\n");
468 goto cant_fix;
469
470 case POLYF:
471 case POLYD:
472 fprintf(ef, "trpfpe: can't fix poly yet\n");
473 goto cant_fix;
474
475 case ACBD:
476 case ACBF:
477 case CMPD:
478 case CMPF:
479 case TSTD:
480 case TSTF:
481 case CVTDB:
482 case CVTDL:
483 case CVTDW:
484 case CVTFB:
485 case CVTFL:
486 case CVTFW:
487 case CVTRDL:
488 case CVTRFL:
489 /* These can generate only reserved operand faults */
490 /* They are shown here for completeness */
491
492 default:
493 fprintf(stderr, "trp: opcode 0x%02x unknown\n",
494 *(--(*ipc)) & 0xff);
495 goto cant_fix;
496 /* NOTREACHED */
497 }
498
499 if (result_type == FLOAT)
500 result_addr->ua_float = retval.rv_float;
501 else
502 {
503 if (result_addr == (anything *)&iR6)
504 { /*
505 * special case - the R6/R7 pair is stored apart
506 */
507 result_addr->ua_long = retval.rv_long[0];
508 ((anything *)&iR7)->ua_long = retval.rv_long[1];
509 }
510 else
511 result_addr->ua_double = retval.rv_double;
512 }
513 signal(SIGFPE, on_fpe);
514 }
515
trpfpe_(count,rval)516 trpfpe_ (count, rval)
517 long *count; /* how many to announce */
518 double *rval; /* dummy return value */
519 {
520 max_messages = *count;
521 retval.rv_double = *rval;
522 sigfpe_dfl = signal(SIGFPE, on_fpe);
523 fpe_count = 0;
524 }
525
526 long
fpecnt_()527 fpecnt_ ()
528 {
529 return (fpe_count);
530 }
531 #endif vax
532
533 #ifdef tahoe
534 /*
535 * This handler just prints a message. It cannot fix anything
536 * on Power6 because of its fpp architecture. In any case, there
537 * are no arithmetic faults (only traps) around, so that no instruction
538 * is interrupted befor it completes, and PC points to the next floating
539 * point instruction (not necessarily next executable instr after the one
540 * that got the exception).
541 */
542
543 struct arglist { /* what AP points to */
544 long al_arg[256];
545 };
546
547 struct reg0_1 {
548 long reg[2];
549 };
550 struct reg2_12 {
551 long reg[11];
552 };
553 #include <sys/types.h>
554 #include <frame.h>
555 #include "sigframe.h"
556
557 /*
558 * bits in the PSL
559 */
560 #include <machine/psl.h>
561
562 /*
563 * where the registers are stored as we see them in the handler
564 */
565
566
567 #define iR0 reg0_1->reg[1]
568 #define iR1 reg0_1->reg[0]
569
570 #define iR2 reg2_12->reg[0]
571 #define iR3 reg2_12->reg[1]
572 #define iR4 reg2_12->reg[2]
573 #define iR5 reg2_12->reg[3]
574 #define iR6 reg2_12->reg[4]
575 #define iR7 reg2_12->reg[5]
576 #define iR8 reg2_12->reg[6]
577 #define iR9 reg2_12->reg[7]
578 #define iR10 reg2_12->reg[8]
579 #define iR11 reg2_12->reg[9]
580 #define iR12 reg2_12->reg[10]
581
582 union objects { /* for load/store */
583 char ua_byte;
584 short ua_word;
585 long ua_long;
586 float ua_float;
587 double ua_double;
588 union objects *ua_anything;
589 };
590
591 typedef union objects anything;
592 enum object_type { BYTE, WORD, LONG, FLOAT, QUAD, DOUBLE, UNKNOWN };
593
594
595 /*
596 * assembly language assist
597 * There are some things you just can't do in C
598 */
599 asm(".text");
600
601 long *myfp();
602 asm("_myfp: .word 0");
603 asm("movl (fp),r0");
604 asm("ret");
605
framep(p)606 struct frame *framep(p)
607 long *p;
608 {
609 return((struct frame *)(p-2));
610 }
611
argp(p)612 struct arglist *argp(p)
613 long *p;
614 {
615 return((struct arglist *)(p+1));
616 }
617
618 char *mysp();
619 asm("_mysp: .word 0");
620 asm("addl3 $4,fp,r0");
621 asm("ret");
622
623 char *mypc();
624 asm("_mypc: .word 0");
625 asm("movl -8(fp),r0");
626 asm("ret");
627
628 asm(".data");
629
630
631 /*
632 * Where interrupted objects are
633 */
634 static struct frame *ifp; /* addr of saved FP */
635 static struct arglist *iap; /* addr of saved AP */
636 static char *isp; /* value of interrupted SP */
637 static char **ipc; /* addr of saved PC */
638 static struct reg0_1 *reg0_1;/* registers 0-1 are saved on the exception */
639 static struct reg2_12 *reg2_12;/* we save 2-12 by our entry mask */
640 static anything *result_addr; /* where the dummy result goes */
641 static enum object_type result_type; /* what kind of object it is */
642
643 /*
644 * some globals
645 */
646 static union {
647 long rv_long[2];
648 float rv_float;
649 double rv_double;
650 } retval; /* the user specified dummy result */
651 static int max_messages = 1; /* the user can tell us */
652 static int fpe_count = 0; /* how bad is it ? */
653 long fpeflt_ = 0; /* fortran "common /fpeflt/ flag" */
654 static sig_t sigfpe_dfl = SIG_DFL; /* if we can't fix it ... */
655
656 /*
657 * The fortran unit control table
658 */
659 extern unit units[];
660
661 /*
662 * Fortran message table is in main
663 */
664 struct msgtbl {
665 char *mesg;
666 int dummy;
667 };
668 extern struct msgtbl act_fpe[];
669
670
671 /* VALID ONLY ON VAX !!!
672 *
673 * Get the address of the (saved) next operand & update saved PC.
674 * The major purpose of this is to determine where to store the result.
675 * There is one case we can't deal with: -(SP) or (SP)+
676 * since we can't change the size of the stack.
677 * Let's just hope compilers don't generate that for results.
678 */
679
680
681 /*
682 * Trap & repair floating exceptions so that a program may proceed.
683 * There is no notion of "correctness" here; just the ability to continue.
684 *
685 * The on_fpe() routine first checks the type code to see if the
686 * exception is repairable. If so, it checks the opcode to see if
687 * it is one that it knows. If this is true, it then simulates the
688 * VAX cpu in retrieving operands in order to increment iPC correctly.
689 * It notes where the result of the operation would have been stored
690 * and substitutes a previously supplied value.
691 * DOES NOT REPAIR ON TAHOE !!!
692 */
693 void
on_fpe(signo,code,sc)694 on_fpe(signo, code, sc)
695 int signo, code;
696 struct sigcontext *sc;
697 {
698 /*
699 * There must be at least 11 register variables here
700 * so our entry mask will save R12-R2.
701 */
702 register long *stk;
703 register long *sp, *rfp;
704 register struct arglist *ap;
705 register struct frame *fp;
706 register FILE *ef;
707 register struct sigframe *sfp;
708 register long dmy1, dmy2, dmy3, dmy4;
709
710 dmy1 = dmy2 = dmy3 = dmy4 = 0;
711
712 ef = units[STDERR].ufd; /* fortran error stream */
713
714 switch (code)
715 {
716 case FPE_INTOVF_TRAP: /* integer overflow */
717 case FPE_INTDIV_TRAP: /* integer divide by zero */
718 case FPE_FLTOVF_TRAP: /* floating overflow */
719 case FPE_FLTDIV_TRAP: /* floating divide by zero */
720 case FPE_FLTUND_TRAP: /* floating underflow */
721 default:
722 cant_fix:
723 if (sigfpe_dfl > (SIG_VAL)7) /* user specified */
724 (*sigfpe_dfl)(signo, code, sc);
725 else
726 if (++fpe_count <= max_messages) {
727 fprintf(ef, "trpfpe: %s",
728 act_fpe[code-1].mesg);
729 if (fpe_count == max_messages)
730 fprintf(ef, ": No more messages will be printed.\n");
731 else
732 fputc('\n', ef);
733 }
734 fpeflt_ = -1;
735 break;
736 }
737
738 /*
739 * Find all the registers just in case something better can be done.
740 */
741
742 rfp = myfp(); /* contents of fp register */
743 ap = argp(rfp); /* my arglist pointer */
744 fp = framep(rfp); /* my frame pointer */
745 ifp = framep(*rfp); /* user's stored in next frame back */
746 iap = argp(*rfp);
747
748 sfp = (struct sigframe *)ap; /* sigframe contains at its bottom the
749 signal handler arguments */
750
751 reg0_1 = (struct reg0_1 *)&sfp->r1;
752 reg2_12 = (struct reg2_12 *)((char *)fp - sizeof (struct reg2_12));
753
754 ipc = (char **)&sc->sc_pc;
755 isp = (char *)sc + sizeof (struct sigcontext);
756 sc->sc_ps &= ~(PSL_V|PSL_FU);
757
758 fprintf(ef, "Current PC = %X \n", sc->sc_pc);
759
760 signal(SIGFPE, on_fpe);
761 sigdie(signo, code, sc);
762 }
763
trpfpe_(count,rval)764 trpfpe_ (count, rval)
765 long *count; /* how many to announce */
766 double *rval; /* dummy return value */
767 {
768 max_messages = *count;
769 retval.rv_double = *rval;
770 sigfpe_dfl = signal(SIGFPE, on_fpe);
771 fpe_count = 0;
772 }
773
774 long
fpecnt_()775 fpecnt_ ()
776 {
777 return (fpe_count);
778 }
779
780 #endif tahoe
781