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