4.3BSD - /usr/src/usr.lib/libF77/trpfpe_.c

   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	7/8/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 *)&reg0_6->reg[regnum];
 193:     else if (regnum <= R11)
 194:         reg_addr = (anything *)&reg7_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: }

Defined functions

Defined variables

Defined struct's

Defined union's

Defined enum's

Defined typedef's

Defined macros