xref: /original-bsd/usr.bin/f77/libF77/trapov_.c (revision 4b9b56dc)
1 /*
2  * Copyright (c) 1980 Regents of the University of California.
3  * All rights reserved.  The Berkeley software License Agreement
4  * specifies the terms and conditions for redistribution.
5  *
6  *	@(#)trapov_.c	5.5	02/14/90
7  *
8  *	Fortran/C floating-point overflow handler
9  *
10  *	The idea of these routines is to catch floating-point overflows
11  *	and print an eror message.  When we then get a reserved operand
12  *	exception, we then fix up the value to the highest possible
13  *	number.  Keen, no?
14  *	Messy, yes!
15  *
16  *	Synopsis:
17  *		call trapov(n)
18  *			causes overflows to be trapped, with the first 'n'
19  *			overflows getting an "Overflow!" message printed.
20  *		k = ovcnt(0)
21  *			causes 'k' to get the number of overflows since the
22  *			last call to trapov().
23  *
24  *	Gary Klimowicz, April 17, 1981
25  *	Integerated with libF77: David Wasley, UCB, July 1981.
26  */
27 
28 # include <stdio.h>
29 # include <sys/signal.h>
30 # include "opcodes.h"
31 # include "../libI77/fiodefs.h"
32 # define SIG_VAL	void (*)()
33 
34 /*
35  *	Potential operand values
36  */
37 typedef	union operand_types {
38 		char	o_byte;
39 		short	o_word;
40 		long	o_long;
41 		float	o_float;
42 		long	o_quad[2];
43 		double	o_double;
44 	} anyval;
45 
46 /*
47  *	the fortran unit control table
48  */
49 extern unit units[];
50 
51 /*
52  * Fortran message table is in main
53  */
54 struct msgtbl {
55 	char	*mesg;
56 	int	dummy;
57 };
58 extern struct msgtbl	act_fpe[];
59 
60 anyval *get_operand_address(), *addr_of_reg();
61 char *opcode_name();
62 
63 /*
64  * trap type codes
65  */
66 # define INT_OVF_T	1
67 # define INT_DIV_T	2
68 # define FLT_OVF_T	3
69 # define FLT_DIV_T	4
70 # define FLT_UND_T	5
71 # define DEC_OVF_T	6
72 # define SUB_RNG_T	7
73 # define FLT_OVF_F	8
74 # define FLT_DIV_F	9
75 # define FLT_UND_F	10
76 
77 # define RES_ADR_F	0
78 # define RES_OPC_F	1
79 # define RES_OPR_F	2
80 
81 #ifdef vax
82 /*
83  *	Operand modes
84  */
85 # define LITERAL0	0x0
86 # define LITERAL1	0x1
87 # define LITERAL2	0x2
88 # define LITERAL3	0x3
89 # define INDEXED	0x4
90 # define REGISTER	0x5
91 # define REG_DEF	0x6
92 # define AUTO_DEC	0x7
93 # define AUTO_INC	0x8
94 # define AUTO_INC_DEF	0x9
95 # define BYTE_DISP	0xa
96 # define BYTE_DISP_DEF	0xb
97 # define WORD_DISP	0xc
98 # define WORD_DISP_DEF	0xd
99 # define LONG_DISP	0xe
100 # define LONG_DISP_DEF	0xf
101 
102 /*
103  *	Operand value types
104  */
105 # define F		1
106 # define D		2
107 # define IDUNNO		3
108 
109 # define PC	0xf
110 # define SP	0xe
111 # define FP	0xd
112 # define AP	0xc
113 
114 /*
115  *	GLOBAL VARIABLES (we need a few)
116  *
117  *	Actual program counter and locations of registers.
118  */
119 static char	*pc;
120 static int	*regs0t6;
121 static int	*regs7t11;
122 static int	max_messages;
123 static int	total_overflows;
124 static union	{
125 	long	v_long[2];
126 	double	v_double;
127 	} retrn;
128 static sig_t sigill_default = (SIG_VAL)-1;
129 static sig_t sigfpe_default;
130 
131 /*
132  *	This routine sets up the signal handler for the floating-point
133  *	and reserved operand interrupts.
134  */
135 
136 trapov_(count, rtnval)
137 	int *count;
138 	double *rtnval;
139 {
140 	void got_overflow(), got_illegal_instruction();
141 
142 	sigfpe_default = signal(SIGFPE, got_overflow);
143 	if (sigill_default == (SIG_VAL)-1)
144 		sigill_default = signal(SIGILL, got_illegal_instruction);
145 	total_overflows = 0;
146 	max_messages = *count;
147 	retrn.v_double = *rtnval;
148 }
149 
150 
151 
152 /*
153  *	got_overflow - routine called when overflow occurs
154  *
155  *	This routine just prints a message about the overflow.
156  *	It is impossible to find the bad result at this point.
157  *	Instead, we wait until we get the reserved operand exception
158  *	when we try to use it.  This raises the SIGILL signal.
159  */
160 
161 /*ARGSUSED*/
162 void
163 got_overflow(signo, codeword, myaddr, pc, ps)
164 	char *myaddr, *pc;
165 {
166 	int	*sp, i;
167 	FILE	*ef;
168 
169 	signal(SIGFPE, got_overflow);
170 	ef = units[STDERR].ufd;
171 	switch (codeword) {
172 		case INT_OVF_T:
173 		case INT_DIV_T:
174 		case FLT_UND_T:
175 		case DEC_OVF_T:
176 		case SUB_RNG_T:
177 		case FLT_OVF_F:
178 		case FLT_DIV_F:
179 		case FLT_UND_F:
180 			if (sigfpe_default > (SIG_VAL)7)
181 				(*sigfpe_default)(signo, codeword, myaddr,
182 				    pc, ps);
183 			else
184 				sigdie(signo, codeword, myaddr, pc, ps);
185 				/* NOTREACHED */
186 
187 		case FLT_OVF_T:
188 		case FLT_DIV_T:
189 			if (++total_overflows <= max_messages) {
190 				fprintf(ef, "trapov: %s",
191 					act_fpe[codeword-1].mesg);
192 				if (total_overflows == max_messages)
193 					fprintf(ef, ": No more messages will be printed.\n");
194 				else
195 					fputc('\n', ef);
196 			}
197 			return;
198 	}
199 }
200 
201 int
202 ovcnt_()
203 {
204 	return total_overflows;
205 }
206 
207 /*
208  *	got_illegal_instruction - handle "illegal instruction" signals.
209  *
210  *	This really deals only with reserved operand exceptions.
211  *	Since there is no way to check this directly, we look at the
212  *	opcode of the instruction we are executing to see if it is a
213  *	floating-point operation (with floating-point operands, not
214  *	just results).
215  *
216  *	This is complicated by the fact that the registers that will
217  *	eventually be restored are saved in two places.  registers 7-11
218  *	are saved by this routine, and are in its call frame. (we have
219  *	to take special care that these registers are specified in
220  *	the procedure entry mask here.)
221  *	Registers 0-6 are saved at interrupt time, and are at a offset
222  *	-8 from the 'signo' parameter below.
223  *	There is ane extremely inimate connection between the value of
224  *	the entry mask set by the 'makefile' script, and the constants
225  *	used in the register offset calculations below.
226  *	Can someone think of a better way to do this?
227  */
228 
229 /*ARGSUSED*/
230 void
231 got_illegal_instruction(signo, codeword, myaddr, trap_pc, ps)
232 	char *myaddr, *trap_pc;
233 {
234 	int first_local[1];		/* must be first */
235 	int i, opcode, type, o_no, no_reserved;
236 	anyval *opnd;
237 
238 	regs7t11 = &first_local[0];
239 	regs0t6 = &signo - 8;
240 	pc = trap_pc;
241 
242 	opcode = fetch_byte() & 0xff;
243 	no_reserved = 0;
244 	if (codeword != RES_OPR_F || !is_floating_operation(opcode)) {
245 		if (sigill_default > (SIG_VAL)7) {
246 			(*sigill_default)(signo, codeword, myaddr, trap_pc, ps);
247 			return;
248 		} else
249 			sigdie(signo, codeword, myaddr, trap_pc, ps);
250 			/* NOTREACHED */
251 	}
252 
253 	if (opcode == POLYD || opcode == POLYF) {
254 		got_illegal_poly(opcode);
255 		return;
256 	}
257 
258 	if (opcode == EMODD || opcode == EMODF) {
259 		got_illegal_emod(opcode);
260 		return;
261 	}
262 
263 	/*
264 	 * This opcode wasn't "unusual".
265 	 * Look at the operands to try and find a reserved operand.
266 	 */
267 	for (o_no = 1; o_no <= no_operands(opcode); ++o_no) {
268 		type = operand_type(opcode, o_no);
269 		if (type != F && type != D) {
270 			advance_pc(type);
271 			continue;
272 		}
273 
274 		/* F or D operand.  Check it out */
275 		opnd = get_operand_address(type);
276 		if (opnd == NULL) {
277 			fprintf(units[STDERR].ufd, "Can't get operand address: 0x%x, %d\n",
278 				pc, o_no);
279 			f77_abort();
280 		}
281 		if (type == F && opnd->o_long == 0x00008000) {
282 			/* found one */
283 			opnd->o_long = retrn.v_long[0];
284 			++no_reserved;
285 		} else if (type == D && opnd->o_long == 0x00008000) {
286 			/* found one here, too! */
287 			opnd->o_quad[0] = retrn.v_long[0];
288 			/* Fix next pointer */
289 			if (opnd == addr_of_reg(6)) opnd = addr_of_reg(7);
290 			else opnd = (anyval *) ((char *) opnd + 4);
291 			opnd->o_quad[0] = retrn.v_long[1];
292 			++no_reserved;
293 		}
294 
295 	}
296 
297 	if (no_reserved == 0) {
298 		fprintf(units[STDERR].ufd, "Can't find any reserved operand!\n");
299 		f77_abort();
300 	}
301 }
302 /*
303  * is_floating_exception - was the operation code for a floating instruction?
304  */
305 
306 is_floating_operation(opcode)
307 	int opcode;
308 {
309 	switch (opcode) {
310 		case ACBD:	case ACBF:	case ADDD2:	case ADDD3:
311 		case ADDF2:	case ADDF3:	case CMPD:	case CMPF:
312 		case CVTDB:	case CVTDF:	case CVTDL:	case CVTDW:
313 		case CVTFB:	case CVTFD:	case CVTFL:	case CVTFW:
314 		case CVTRDL:	case CVTRFL:	case DIVD2:	case DIVD3:
315 		case DIVF2:	case DIVF3:	case EMODD:	case EMODF:
316 		case MNEGD:	case MNEGF:	case MOVD:	case MOVF:
317 		case MULD2:	case MULD3:	case MULF2:	case MULF3:
318 		case POLYD:	case POLYF:	case SUBD2:	case SUBD3:
319 		case SUBF2:	case SUBF3:	case TSTD:	case TSTF:
320 			return 1;
321 
322 		default:
323 			return 0;
324 	}
325 }
326 /*
327  * got_illegal_poly - handle an illegal POLY[DF] instruction.
328  *
329  * We don't do anything here yet.
330  */
331 
332 /*ARGSUSED*/
333 got_illegal_poly(opcode)
334 {
335 	fprintf(units[STDERR].ufd, "Can't do 'poly' instructions yet\n");
336 	f77_abort();
337 }
338 
339 
340 
341 /*
342  * got_illegal_emod - handle illegal EMOD[DF] instruction.
343  *
344  * We don't do anything here yet.
345  */
346 
347 /*ARGSUSED*/
348 got_illegal_emod(opcode)
349 {
350 	fprintf(units[STDERR].ufd, "Can't do 'emod' instructions yet\n");
351 	f77_abort();
352 }
353 
354 
355 /*
356  *	no_operands - determine the number of operands in this instruction.
357  *
358  */
359 
360 no_operands(opcode)
361 {
362 	switch (opcode) {
363 		case ACBD:
364 		case ACBF:
365 			return 3;
366 
367 		case MNEGD:
368 		case MNEGF:
369 		case MOVD:
370 		case MOVF:
371 		case TSTD:
372 		case TSTF:
373 			return 1;
374 
375 		default:
376 			return 2;
377 	}
378 }
379 
380 
381 
382 /*
383  *	operand_type - is the operand a D or an F?
384  *
385  *	We are only descriminating between Floats and Doubles here.
386  *	Other operands may be possible on exotic instructions.
387  */
388 
389 /*ARGSUSED*/
390 operand_type(opcode, no)
391 {
392 	if (opcode >= 0x40 && opcode <= 0x56) return F;
393 	if (opcode >= 0x60 && opcode <= 0x76) return D;
394 	return IDUNNO;
395 }
396 
397 
398 
399 /*
400  *	advance_pc - Advance the program counter past an operand.
401  *
402  *	We just bump the pc by the appropriate values.
403  */
404 
405 advance_pc(type)
406 {
407 	register int mode, reg;
408 
409 	mode = fetch_byte();
410 	reg = mode & 0xf;
411 	mode = (mode >> 4) & 0xf;
412 	switch (mode) {
413 		case LITERAL0:
414 		case LITERAL1:
415 		case LITERAL2:
416 		case LITERAL3:
417 			return;
418 
419 		case INDEXED:
420 			advance_pc(type);
421 			return;
422 
423 		case REGISTER:
424 		case REG_DEF:
425 		case AUTO_DEC:
426 			return;
427 
428 		case AUTO_INC:
429 			if (reg == PC) {
430 				if (type == F) (void) fetch_long();
431 				else if (type == D) {
432 					(void) fetch_long();
433 					(void) fetch_long();
434 				} else {
435 					fprintf(units[STDERR].ufd, "Bad type %d in advance\n",
436 						type);
437 					f77_abort();
438 				}
439 			}
440 			return;
441 
442 		case AUTO_INC_DEF:
443 			if (reg == PC) (void) fetch_long();
444 			return;
445 
446 		case BYTE_DISP:
447 		case BYTE_DISP_DEF:
448 			(void) fetch_byte();
449 			return;
450 
451 		case WORD_DISP:
452 		case WORD_DISP_DEF:
453 			(void) fetch_word();
454 			return;
455 
456 		case LONG_DISP:
457 		case LONG_DISP_DEF:
458 			(void) fetch_long();
459 			return;
460 
461 		default:
462 			fprintf(units[STDERR].ufd, "Bad mode 0x%x in op_length()\n", mode);
463 			f77_abort();
464 	}
465 }
466 
467 
468 anyval *
469 get_operand_address(type)
470 {
471 	register int mode, reg, base;
472 
473 	mode = fetch_byte() & 0xff;
474 	reg = mode & 0xf;
475 	mode = (mode >> 4) & 0xf;
476 	switch (mode) {
477 		case LITERAL0:
478 		case LITERAL1:
479 		case LITERAL2:
480 		case LITERAL3:
481 			return NULL;
482 
483 		case INDEXED:
484 			base = (int) get_operand_address(type);
485 			if (base == NULL) return NULL;
486 			base += contents_of_reg(reg)*type_length(type);
487 			return (anyval *) base;
488 
489 		case REGISTER:
490 			return addr_of_reg(reg);
491 
492 		case REG_DEF:
493 			return (anyval *) contents_of_reg(reg);
494 
495 		case AUTO_DEC:
496 			return (anyval *) (contents_of_reg(reg)
497 				- type_length(type));
498 
499 		case AUTO_INC:
500 			return (anyval *) contents_of_reg(reg);
501 
502 		case AUTO_INC_DEF:
503 			return (anyval *) * (long *) contents_of_reg(reg);
504 
505 		case BYTE_DISP:
506 			base = fetch_byte();
507 			base += contents_of_reg(reg);
508 			return (anyval *) base;
509 
510 		case BYTE_DISP_DEF:
511 			base = fetch_byte();
512 			base += contents_of_reg(reg);
513 			return (anyval *) * (long *) base;
514 
515 		case WORD_DISP:
516 			base = fetch_word();
517 			base += contents_of_reg(reg);
518 			return (anyval *) base;
519 
520 		case WORD_DISP_DEF:
521 			base = fetch_word();
522 			base += contents_of_reg(reg);
523 			return (anyval *) * (long *) base;
524 
525 		case LONG_DISP:
526 			base = fetch_long();
527 			base += contents_of_reg(reg);
528 			return (anyval *) base;
529 
530 		case LONG_DISP_DEF:
531 			base = fetch_long();
532 			base += contents_of_reg(reg);
533 			return (anyval *) * (long *) base;
534 
535 		default:
536 			fprintf(units[STDERR].ufd, "Bad mode 0x%x in get_addr()\n", mode);
537 			f77_abort();
538 	}
539 	return NULL;
540 }
541 
542 
543 
544 contents_of_reg(reg)
545 {
546 	int value;
547 
548 	if (reg == PC) value = (int) pc;
549 	else if (reg == SP) value = (int) &regs0t6[6];
550 	else if (reg == FP) value = regs0t6[-2];
551 	else if (reg == AP) value = regs0t6[-3];
552 	else if (reg >= 0 && reg <= 6) value = regs0t6[reg];
553 	else if (reg >= 7 && reg <= 11) value = regs7t11[reg];
554 	else {
555 		fprintf(units[STDERR].ufd, "Bad register 0x%x to contents_of()\n", reg);
556 		f77_abort();
557 		value = -1;
558 	}
559 	return value;
560 }
561 
562 
563 anyval *
564 addr_of_reg(reg)
565 {
566 	if (reg >= 0 && reg <= 6) {
567 		return (anyval *) &regs0t6[reg];
568 	}
569 	if (reg >= 7 && reg <= 11) {
570 		return (anyval *) &regs7t11[reg];
571 	}
572 	fprintf(units[STDERR].ufd, "Bad reg 0x%x to addr_of()\n", reg);
573 	f77_abort();
574 	return NULL;
575 }
576 /*
577  *	fetch_{byte, word, long} - extract values from the PROGRAM area.
578  *
579  *	These routines are used in the operand decoding to extract various
580  *	fields from where the program counter points.  This is because the
581  *	addressing on the Vax is dynamic: the program counter advances
582  *	while we are grabbing operands, as well as when we pass instructions.
583  *	This makes things a bit messy, but I can't help it.
584  */
585 fetch_byte()
586 {
587 	return *pc++;
588 }
589 
590 
591 
592 fetch_word()
593 {
594 	int *old_pc;
595 
596 	old_pc = (int *) pc;
597 	pc += 2;
598 	return *old_pc;
599 }
600 
601 
602 
603 fetch_long()
604 {
605 	long *old_pc;
606 
607 	old_pc = (long *) pc;
608 	pc += 4;
609 	return *old_pc;
610 }
611 
612 
613 type_length(type)
614 {
615 	if (type == F) return 4;
616 	if (type == D) return 8;
617 	fprintf(units[STDERR].ufd, "Bad type 0x%x in type_length()\n", type);
618 	f77_abort();
619 	return -1;
620 }
621 
622 
623 
624 char *opcode_name(opcode)
625 {
626 	switch (opcode) {
627 		case ACBD: 	return "ACBD";
628 		case ACBF: 	return "ACBF";
629 		case ADDD2: 	return "ADDD2";
630 		case ADDD3: 	return "ADDD3";
631 		case ADDF2: 	return "ADDF2";
632 		case ADDF3: 	return "ADDF3";
633 		case CMPD: 	return "CMPD";
634 		case CMPF: 	return "CMPF";
635 		case CVTDB: 	return "CVTDB";
636 		case CVTDF: 	return "CVTDF";
637 		case CVTDL: 	return "CVTDL";
638 		case CVTDW: 	return "CVTDW";
639 		case CVTFB: 	return "CVTFB";
640 		case CVTFD: 	return "CVTFD";
641 		case CVTFL: 	return "CVTFL";
642 		case CVTFW: 	return "CVTFW";
643 		case CVTRDL: 	return "CVTRDL";
644 		case CVTRFL: 	return "CVTRFL";
645 		case DIVD2: 	return "DIVD2";
646 		case DIVD3: 	return "DIVD3";
647 		case DIVF2: 	return "DIVF2";
648 		case DIVF3: 	return "DIVF3";
649 		case EMODD: 	return "EMODD";
650 		case EMODF: 	return "EMODF";
651 		case MNEGD: 	return "MNEGD";
652 		case MNEGF: 	return "MNEGF";
653 		case MOVD: 	return "MOVD";
654 		case MOVF: 	return "MOVF";
655 		case MULD2: 	return "MULD2";
656 		case MULD3: 	return "MULD3";
657 		case MULF2: 	return "MULF2";
658 		case MULF3: 	return "MULF3";
659 		case POLYD: 	return "POLYD";
660 		case POLYF: 	return "POLYF";
661 		case SUBD2: 	return "SUBD2";
662 		case SUBD3: 	return "SUBD3";
663 		case SUBF2: 	return "SUBF2";
664 		case SUBF3: 	return "SUBF3";
665 		case TSTD: 	return "TSTD";
666 		case TSTF: 	return "TSTF";
667 	}
668 }
669 #endif	vax
670 
671 #ifdef tahoe
672 /*
673  *	NO RESERVED OPERAND EXCEPTION ON RESULT OF FP OVERFLOW ON TAHOE.
674  * 	JUST PRINT THE OVERFLOW MESSAGE. RESULT IS 0 (zero).
675  */
676 
677 /*
678  *	GLOBAL VARIABLES (we need a few)
679  *
680  *	Actual program counter and locations of registers.
681  */
682 static char	*pc;
683 static int	*regs0t1;
684 static int	*regs2t12;
685 static int	max_messages;
686 static int	total_overflows;
687 static union	{
688 	long	v_long[2];
689 	double	v_double;
690 	} retrn;
691 static sig_t sigill_default = (SIG_VAL)-1;
692 static sig_t sigfpe_default;
693 
694 
695 /*
696  *	This routine sets up the signal handler for the floating-point
697  *	and reserved operand interrupts.
698  */
699 
700 trapov_(count, rtnval)
701 	int *count;
702 	double *rtnval;
703 {
704 	void got_overflow();
705 
706 	sigfpe_default = signal(SIGFPE, got_overflow);
707 	total_overflows = 0;
708 	max_messages = *count;
709 	retrn.v_double = *rtnval;
710 }
711 
712 
713 
714 /*
715  *	got_overflow - routine called when overflow occurs
716  *
717  *	This routine just prints a message about the overflow.
718  *	It is impossible to find the bad result at this point.
719  * 	 NEXT 2 LINES DON'T HOLD FOR TAHOE !
720  *	Instead, we wait until we get the reserved operand exception
721  *	when we try to use it.  This raises the SIGILL signal.
722  */
723 
724 /*ARGSUSED*/
725 void
726 got_overflow(signo, codeword, sc)
727 	int signo, codeword;
728 	struct sigcontext *sc;
729 {
730 	int	*sp, i;
731 	FILE	*ef;
732 
733 	signal(SIGFPE, got_overflow);
734 	ef = units[STDERR].ufd;
735 	switch (codeword) {
736 		case INT_OVF_T:
737 		case INT_DIV_T:
738 		case FLT_UND_T:
739 		case FLT_DIV_T:
740 			if (sigfpe_default > (SIG_VAL)7)
741 				(*sigfpe_default)(signo, codeword, sc);
742 			else
743 				sigdie(signo, codeword, sc);
744 				/* NOTREACHED */
745 
746 		case FLT_OVF_T:
747 			if (++total_overflows <= max_messages) {
748 				fprintf(ef, "trapov: %s",
749 					act_fpe[codeword-1].mesg);
750 				fprintf(ef, ": Current PC = %X", sc->sc_pc);
751 				if (total_overflows == max_messages)
752 					fprintf(ef, ": No more messages will be printed.\n");
753 				else
754 					fputc('\n', ef);
755 			}
756 			return;
757 	}
758 }
759 int
760 ovcnt_()
761 {
762 	return total_overflows;
763 }
764 #endif tahoe
765