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.4 11/04/86 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 <signal.h> 31 #include "../libI77/fiodefs.h" 32 33 #define SIG_VAL int (*)() 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 int (*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 on_fpe(signo, code, sc, grbg) 332 int signo, code; 333 struct sigcontext *sc; 334 #endif 335 { 336 /* 337 * There must be at least 5 register variables here 338 * so our entry mask will save R11-R7. 339 */ 340 register long *stk; 341 register long *sp; 342 register struct arglist *ap; 343 register struct cframe *fp; 344 register FILE *ef; 345 346 ef = units[STDERR].ufd; /* fortran error stream */ 347 348 switch (code) 349 { 350 case FPE_INTOVF_TRAP: /* integer overflow */ 351 case FPE_INTDIV_TRAP: /* integer divide by zero */ 352 case FPE_FLTOVF_TRAP: /* floating overflow */ 353 case FPE_FLTDIV_TRAP: /* floating/decimal divide by zero */ 354 case FPE_FLTUND_TRAP: /* floating underflow */ 355 case FPE_DECOVF_TRAP: /* decimal overflow */ 356 case FPE_SUBRNG_TRAP: /* subscript out of range */ 357 default: 358 cant_fix: 359 if (sigfpe_dfl > (SIG_VAL)7) /* user specified */ 360 #ifdef OLD_BSD 361 return((*sigfpe_dfl)(signo, code, myaddr, pc, ps)); 362 #else 363 return((*sigfpe_dfl)(signo, code, sc, grbg)); 364 #endif 365 else 366 #ifdef OLD_BSD 367 sigdie(signo, code, myaddr, pc, ps); 368 #else 369 sigdie(signo, code, sc, grbg); 370 #endif 371 /* NOTREACHED */ 372 373 case FPE_FLTOVF_FAULT: /* floating overflow fault */ 374 case FPE_FLTDIV_FAULT: /* divide by zero floating fault */ 375 case FPE_FLTUND_FAULT: /* floating underflow fault */ 376 if (++fpe_count <= max_messages) { 377 fprintf(ef, "trpfpe: %s", 378 act_fpe[code-1].mesg); 379 if (fpe_count == max_messages) 380 fprintf(ef, ": No more messages will be printed.\n"); 381 else 382 fputc('\n', ef); 383 } 384 fpeflt_ = -1; 385 break; 386 } 387 388 ap = myap(); /* my arglist pointer */ 389 fp = myfp(); /* my frame pointer */ 390 ifp = &(fp->cf_fp)->cf_fp; /* user's stored in next frame back */ 391 iap = &(fp->cf_fp)->cf_ap; 392 /* 393 * these are likely to be system dependent 394 */ 395 reg0_6 = (struct reg0_6 *)((char *)fp->cf_fp + sizeof (struct cframe)); 396 reg7_11 = (struct reg7_11 *)((char *)fp->cf_fp - sizeof (struct reg7_11)); 397 398 #ifdef OLD_BSD 399 ipc = &pc; 400 isp = (char *)&ap->al_arg[ap->al_numarg + 2]; /* assumes 2 dummys */ 401 ps &= ~(PSW_V|PSW_FU); 402 #else 403 ipc = (char **)&sc->sc_pc; 404 isp = (char *)sc + sizeof (struct sigcontext); 405 sc->sc_ps &= ~(PSW_V|PSW_FU); 406 #endif 407 408 409 switch (*(*ipc)++) 410 { 411 case ADDD3: 412 case DIVD3: 413 case MULD3: 414 case SUBD3: 415 (void) get_operand(sizeof (double)); 416 /* intentional fall-thru */ 417 418 case ADDD2: 419 case DIVD2: 420 case MULD2: 421 case SUBD2: 422 case MNEGD: 423 case MOVD: 424 (void) get_operand(sizeof (double)); 425 result_addr = get_operand(sizeof (double)); 426 result_type = DOUBLE; 427 break; 428 429 case ADDF3: 430 case DIVF3: 431 case MULF3: 432 case SUBF3: 433 (void) get_operand(sizeof (float)); 434 /* intentional fall-thru */ 435 436 case ADDF2: 437 case DIVF2: 438 case MULF2: 439 case SUBF2: 440 case MNEGF: 441 case MOVF: 442 (void) get_operand(sizeof (float)); 443 result_addr = get_operand(sizeof (float)); 444 result_type = FLOAT; 445 break; 446 447 case CVTDF: 448 (void) get_operand(sizeof (double)); 449 result_addr = get_operand(sizeof (float)); 450 result_type = FLOAT; 451 break; 452 453 case CVTFD: 454 (void) get_operand(sizeof (float)); 455 result_addr = get_operand(sizeof (double)); 456 result_type = DOUBLE; 457 break; 458 459 case EMODF: 460 case EMODD: 461 fprintf(ef, "trpfpe: can't fix emod yet\n"); 462 goto cant_fix; 463 464 case POLYF: 465 case POLYD: 466 fprintf(ef, "trpfpe: can't fix poly yet\n"); 467 goto cant_fix; 468 469 case ACBD: 470 case ACBF: 471 case CMPD: 472 case CMPF: 473 case TSTD: 474 case TSTF: 475 case CVTDB: 476 case CVTDL: 477 case CVTDW: 478 case CVTFB: 479 case CVTFL: 480 case CVTFW: 481 case CVTRDL: 482 case CVTRFL: 483 /* These can generate only reserved operand faults */ 484 /* They are shown here for completeness */ 485 486 default: 487 fprintf(stderr, "trp: opcode 0x%02x unknown\n", 488 *(--(*ipc)) & 0xff); 489 goto cant_fix; 490 /* NOTREACHED */ 491 } 492 493 if (result_type == FLOAT) 494 result_addr->ua_float = retval.rv_float; 495 else 496 { 497 if (result_addr == (anything *)&iR6) 498 { /* 499 * special case - the R6/R7 pair is stored apart 500 */ 501 result_addr->ua_long = retval.rv_long[0]; 502 ((anything *)&iR7)->ua_long = retval.rv_long[1]; 503 } 504 else 505 result_addr->ua_double = retval.rv_double; 506 } 507 signal(SIGFPE, on_fpe); 508 } 509 510 trpfpe_ (count, rval) 511 long *count; /* how many to announce */ 512 double *rval; /* dummy return value */ 513 { 514 max_messages = *count; 515 retval.rv_double = *rval; 516 sigfpe_dfl = signal(SIGFPE, on_fpe); 517 fpe_count = 0; 518 } 519 520 long 521 fpecnt_ () 522 { 523 return (fpe_count); 524 } 525 #endif vax 526 527 #ifdef tahoe 528 /* 529 * This handler just prints a message. It cannot fix anything 530 * on Power6 because of its fpp architecture. In any case, there 531 * are no arithmetic faults (only traps) around, so that no instruction 532 * is interrupted befor it completes, and PC points to the next floating 533 * point instruction (not necessarily next executable instr after the one 534 * that got the exception). 535 */ 536 537 struct arglist { /* what AP points to */ 538 long al_arg[256]; 539 }; 540 541 struct reg0_1 { 542 long reg[2]; 543 }; 544 struct reg2_12 { 545 long reg[11]; 546 }; 547 #include <sys/types.h> 548 #include <frame.h> 549 #include "sigframe.h" 550 551 /* 552 * bits in the PSL 553 */ 554 #include <machine/psl.h> 555 556 /* 557 * where the registers are stored as we see them in the handler 558 */ 559 560 561 #define iR0 reg0_1->reg[1] 562 #define iR1 reg0_1->reg[0] 563 564 #define iR2 reg2_12->reg[0] 565 #define iR3 reg2_12->reg[1] 566 #define iR4 reg2_12->reg[2] 567 #define iR5 reg2_12->reg[3] 568 #define iR6 reg2_12->reg[4] 569 #define iR7 reg2_12->reg[5] 570 #define iR8 reg2_12->reg[6] 571 #define iR9 reg2_12->reg[7] 572 #define iR10 reg2_12->reg[8] 573 #define iR11 reg2_12->reg[9] 574 #define iR12 reg2_12->reg[10] 575 576 union objects { /* for load/store */ 577 char ua_byte; 578 short ua_word; 579 long ua_long; 580 float ua_float; 581 double ua_double; 582 union objects *ua_anything; 583 }; 584 585 typedef union objects anything; 586 enum object_type { BYTE, WORD, LONG, FLOAT, QUAD, DOUBLE, UNKNOWN }; 587 588 589 /* 590 * assembly language assist 591 * There are some things you just can't do in C 592 */ 593 asm(".text"); 594 595 long *myfp(); 596 asm("_myfp: .word 0"); 597 asm("movl (fp),r0"); 598 asm("ret"); 599 600 struct frame *framep(p) 601 long *p; 602 { 603 return((struct frame *)(p-2)); 604 } 605 606 struct arglist *argp(p) 607 long *p; 608 { 609 return((struct arglist *)(p+1)); 610 } 611 612 char *mysp(); 613 asm("_mysp: .word 0"); 614 asm("addl3 $4,fp,r0"); 615 asm("ret"); 616 617 char *mypc(); 618 asm("_mypc: .word 0"); 619 asm("movl -8(fp),r0"); 620 asm("ret"); 621 622 asm(".data"); 623 624 625 /* 626 * Where interrupted objects are 627 */ 628 static struct frame *ifp; /* addr of saved FP */ 629 static struct arglist *iap; /* addr of saved AP */ 630 static char *isp; /* value of interrupted SP */ 631 static char **ipc; /* addr of saved PC */ 632 static struct reg0_1 *reg0_1;/* registers 0-1 are saved on the exception */ 633 static struct reg2_12 *reg2_12;/* we save 2-12 by our entry mask */ 634 static anything *result_addr; /* where the dummy result goes */ 635 static enum object_type result_type; /* what kind of object it is */ 636 637 /* 638 * some globals 639 */ 640 static union { 641 long rv_long[2]; 642 float rv_float; 643 double rv_double; 644 } retval; /* the user specified dummy result */ 645 static int max_messages = 1; /* the user can tell us */ 646 static int fpe_count = 0; /* how bad is it ? */ 647 long fpeflt_ = 0; /* fortran "common /fpeflt/ flag" */ 648 static int (*sigfpe_dfl)() = SIG_DFL; /* if we can't fix it ... */ 649 650 /* 651 * The fortran unit control table 652 */ 653 extern unit units[]; 654 655 /* 656 * Fortran message table is in main 657 */ 658 struct msgtbl { 659 char *mesg; 660 int dummy; 661 }; 662 extern struct msgtbl act_fpe[]; 663 664 665 /* VALID ONLY ON VAX !!! 666 * 667 * Get the address of the (saved) next operand & update saved PC. 668 * The major purpose of this is to determine where to store the result. 669 * There is one case we can't deal with: -(SP) or (SP)+ 670 * since we can't change the size of the stack. 671 * Let's just hope compilers don't generate that for results. 672 */ 673 674 675 /* 676 * Trap & repair floating exceptions so that a program may proceed. 677 * There is no notion of "correctness" here; just the ability to continue. 678 * 679 * The on_fpe() routine first checks the type code to see if the 680 * exception is repairable. If so, it checks the opcode to see if 681 * it is one that it knows. If this is true, it then simulates the 682 * VAX cpu in retrieving operands in order to increment iPC correctly. 683 * It notes where the result of the operation would have been stored 684 * and substitutes a previously supplied value. 685 * DOES NOT REPAIR ON TAHOE !!! 686 */ 687 688 on_fpe(signo, code, sc) 689 int signo, code; 690 struct sigcontext *sc; 691 { 692 /* 693 * There must be at least 11 register variables here 694 * so our entry mask will save R12-R2. 695 */ 696 register long *stk; 697 register long *sp, *rfp; 698 register struct arglist *ap; 699 register struct frame *fp; 700 register FILE *ef; 701 register struct sigframe *sfp; 702 register long dmy1, dmy2, dmy3, dmy4; 703 704 dmy1 = dmy2 = dmy3 = dmy4 = 0; 705 706 ef = units[STDERR].ufd; /* fortran error stream */ 707 708 switch (code) 709 { 710 case FPE_INTOVF_TRAP: /* integer overflow */ 711 case FPE_INTDIV_TRAP: /* integer divide by zero */ 712 case FPE_FLTOVF_TRAP: /* floating overflow */ 713 case FPE_FLTDIV_TRAP: /* floating divide by zero */ 714 case FPE_FLTUND_TRAP: /* floating underflow */ 715 default: 716 cant_fix: 717 if (sigfpe_dfl > (SIG_VAL)7) /* user specified */ 718 return((*sigfpe_dfl)(signo, code, sc)); 719 else 720 if (++fpe_count <= max_messages) { 721 fprintf(ef, "trpfpe: %s", 722 act_fpe[code-1].mesg); 723 if (fpe_count == max_messages) 724 fprintf(ef, ": No more messages will be printed.\n"); 725 else 726 fputc('\n', ef); 727 } 728 fpeflt_ = -1; 729 break; 730 } 731 732 /* 733 * Find all the registers just in case something better can be done. 734 */ 735 736 rfp = myfp(); /* contents of fp register */ 737 ap = argp(rfp); /* my arglist pointer */ 738 fp = framep(rfp); /* my frame pointer */ 739 ifp = framep(*rfp); /* user's stored in next frame back */ 740 iap = argp(*rfp); 741 742 sfp = (struct sigframe *)ap; /* sigframe contains at its bottom the 743 signal handler arguments */ 744 745 reg0_1 = (struct reg0_1 *)&sfp->r1; 746 reg2_12 = (struct reg2_12 *)((char *)fp - sizeof (struct reg2_12)); 747 748 ipc = (char **)&sc->sc_pc; 749 isp = (char *)sc + sizeof (struct sigcontext); 750 sc->sc_ps &= ~(PSL_V|PSL_FU); 751 752 fprintf(ef, "Current PC = %X \n", sc->sc_pc); 753 754 signal(SIGFPE, on_fpe); 755 sigdie(signo, code, sc); 756 } 757 758 trpfpe_ (count, rval) 759 long *count; /* how many to announce */ 760 double *rval; /* dummy return value */ 761 { 762 max_messages = *count; 763 retval.rv_double = *rval; 764 sigfpe_dfl = signal(SIGFPE, on_fpe); 765 fpe_count = 0; 766 } 767 768 long 769 fpecnt_ () 770 { 771 return (fpe_count); 772 } 773 774 #endif tahoe 775