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