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 02/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 776