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.3 07/08/85 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 "opcodes.h" 32 #include "operand.h" 33 #include "../libI77/fiodefs.h" 34 35 #define SIG_VAL int (*)() 36 37 #if vax /* only works on VAXen */ 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 #endif vax 510 511 trpfpe_ (count, rval) 512 long *count; /* how many to announce */ 513 double *rval; /* dummy return value */ 514 { 515 #if vax 516 max_messages = *count; 517 retval.rv_double = *rval; 518 sigfpe_dfl = signal(SIGFPE, on_fpe); 519 fpe_count = 0; 520 #endif 521 } 522 523 long 524 fpecnt_ () 525 { 526 #if vax 527 return (fpe_count); 528 #else 529 return (0L); 530 #endif 531 } 532 533