C+
C Example condition handler and user-action routine using
C LIB$DECODE_FAULT. This example demonstrates the use of
C most of the features of LIB$DECODE_FAULT. Its purpose
C is to handle floating underflow and overflow faults,
C replacing the result of the instruction with the correctly
C signed smallest possible value for underflows, or greatest
C possible value for overflows.
C
C For simplicity, faults involving the POLYx instructions are
C not handled.
C
C***
C FIXUP_RESULT is the condition handler enabled by the program
C desiring the fixup of overflows and underflows.
C***
C-
INTEGER*4 FUNCTION FIXUP_RESULT(SIGARGS, MECHARGS)
IMPLICIT NONE
INCLUDE '($SSDEF)' ! SS$_ symbols
INCLUDE '($LIBDCFDEF)' ! LIB$DECODE_FAULT symbols
INTEGER*4 SIGARGS(1:*) ! Signal arguments list
INTEGER*4 MECHARGS(1:*) ! Mechanism arguments list
C+
C This is a sample redefinition of MULH3 instruction.
C-
BYTE OPTABLE(8) /'FD'X,'65'X, ! MULH3 opcode
1 LIB$K_DCFOPR_RH, ! Read H_floating
2 LIB$K_DCFOPR_RH, ! Read H_floating
3 LIB$K_DCFOPR_WH, ! Write H_floating
4 LIB$K_DCFOPR_END, ! End of operands
5 'FF'X,'FF'X/ ! End of instructions
INTEGER*4 LIB$DECODE_FAULT ! External function
EXTERNAL FIXUP_ACTION ! Action routine to do the fixup
C+
C Determine if the exception is one we want to handle.
C-
IF ((SIGARGS(2) .EQ. SS$_FLTOVF_F) .OR.
1 (SIGARGS(2) .EQ. SS$_FLTUND_F)) THEN
C+
C We think we can handle the fault. Call
C LIB$DECODE_FAULT and pass it the signal arguments and
C the address of our action routine and opcode table.
C-
FIXUP_RESULT = LIB$DECODE_FAULT (SIGARGS,
1 MECHARGS, %DESCR(FIXUP_ACTION),, OPTABLE)
RETURN
END IF
C+
C We can only get here if we couldn't handle the fault.
C Resignal the exception.
C-
FIXUP_RESULT = SS$_RESIGNAL
RETURN
END
C+
C User action routine to handle the fault.
C-
INTEGER*4 FUNCTION FIXUP_ACTION (OPCODE,INSTR_PC,PSL,
1 REGISTERS,OP_COUNT,
2 OP_TYPES,READ_OPS,
3 WRITE_OPS,SIGARGS,
4 SIGNAL_ROUT,CONTEXT,
5 USER_ARG,ORIG_REGS)
IMPLICIT NONE
INCLUDE '($SSDEF)' ! SS$_ definitions
INCLUDE '($PSLDEF)' ! PSL$ definitions
INCLUDE '($LIBDCFDEF)' ! LIB$DECODE_FAULT
! definitions
INTEGER*4 OPCODE ! Instruction opcode
INTEGER*4 INSTR_PC ! PC of this instruction
INTEGER*4 PSL ! Processor status
! longword
INTEGER*4 REGISTERS(0:15) ! R0-R15 contents
INTEGER*4 OP_COUNT ! Number of operands
INTEGER*4 OP_TYPES(1:*) ! Types of operands
INTEGER*4 READ_OPS(1:*) ! Addresses of read operands
INTEGER*4 WRITE_OPS(1:*) ! Addresses of write operands
INTEGER*4 SIGARGS(1:*) ! Signal argument list
INTEGER*4 SIGNAL_ROUT ! Signal routine address
INTEGER*4 CONTEXT ! Signal routine context
INTEGER*4 USER_ARG ! User argument value
INTEGER*4 ORIG_REGS(0:15) ! Original registers
C+
C Declare and initialize table of class codes for each of the
C "real" opcodes. We'll index into this by the first byte of
C one-byte opcodes, the second byte of two-byte opcodes. The
C class codes will be used in a computed GOTO (CASE). The
C codes are:
C 0 - Unsupported
C 1 - ADD
C 2 - SUB
C 3 - MUL,DIV
C 4 - ACB
C 5 - CVT
C 6 - EMOD
C
C The class mainly determines how we compute the sign of the
C result, except for ACB.
C-
BYTE INST_CLASS_TABLE(0:255)
DATA INST_CLASS_TABLE /
1 48*0, ! 00-2F
2 0,0,0,5,0,0,0,0,0,0,0,0,0,0,0,0, ! 30-3F
3 1,1,2,2,3,3,3,3,0,0,0,0,0,0,0,4, ! 40-4F
4 0,0,0,0,6,0,0,0,0,0,0,0,0,0,0,0, ! 50-5F
5 1,1,2,2,3,3,3,3,0,0,0,0,0,0,0,4, ! 60-6F
6 0,0,0,0,6,0,5,0,0,0,0,0,0,0,0,0, ! 70-7F
7 112*0, ! 80-EF
8 0,0,0,0,0,0,5,5,0,0,0,0,0,0,0,0/ ! F0-FF
C+
C Table of operand sizes in 8-bit bytes, indexed by the
C datatype code contained in the OP_TYPES array. Only floating
C types matter.
C-
BYTE OP_SIZES(9) /0,0,0,0,0,4,8,8,16/
INTEGER*4 LIB$EXTV ! External function
INTEGER*4 RESULT_NEGATIVE ! -1 if result negative,
! 0 if positive
INTEGER*4 SIGN1,SIGN2,SIGN3 ! Signs of operands
INTEGER*4 INST_BYTE ! Current opcode byte
INTEGER*4 INST_CLASS ! Class of instruction
! from table
INTEGER*4 OP_DTYPE ! Datatype of operand
INTEGER*4 OP_SIZE ! Size of operand in
! 8-bit bytes
INTEGER*4 RESULT_OP ! Position of result
! in WRITE_OPS array
LOGICAL*4 OVERFLOW ! TRUE if SS$_FLTOVF_F
LOGICAL*4 SMALLER ! Function which
! compares operands
PARAMETER ESCD = '0FD'X ! First byte of G,H instructions
INTEGER*2 SMALL_F(2) ! Smallest F_floating
DATA SMALL_F /'0080'X,0/
INTEGER*2 SMALL_D(4) ! Smallest D_floating
DATA SMALL_D /'0080'X,0,0,0/
INTEGER*2 SMALL_G(4) ! Smallest G_floating
DATA SMALL_G /'0010'X,0,0,0/
INTEGER*2 SMALL_H(8) ! Smallest H_floating
DATA SMALL_H /'0001'X,0,0,0,0,0,0,0/
INTEGER*2 BIGGEST(8) ! Biggest value (all datatypes)
DATA BIGGEST /'7FFF'X,7*'FFFF'X/
INTEGER*4 SIGNAL_ARRAY(2) ! Array for signalling new
! exception
C+
C
C NOTE: Because the operands arrays contain the locations of
C the operands, rather than the operands themselves,
C we must call a routine using the %VAL function to
C "fool" the called routine into considering the
C contents of an operands array element as the address
C of an item. This would not be necessary in a
C language that understood the concept of pointer
C variables, such as PASCAL.
C
C
C If FPD is set in the PSL, signal SS$_ROPRAND (reserved operand). In
C reality this shouldn't happen since none of the instructions we
C handle can set FPD, but do it as an example.
C-
IF (BTEST(PSL,PSL$V_FPD)) THEN
SIGNAL_ARRAY(1) = 1 ! Count of signal arguments
SIGNAL_ARRAY(2) = SS$_ROPRAND ! Error status value
CALL SIGNAL_ROUT (
1 1, ! Fault flag - signal as fault
2 SIGNAL_ARRAY, ! Signal arguments array
3 CONTEXT) ! Context as passed to us
! Call will never return
END IF
C+
C Set OVERFLOW according to the exception type. We assume that
C the only alternatives are SS$_FLTOVF_F and SS$_FLTUND_F.
C-
OVERFLOW = (SIGARGS(2) .EQ. SS$_FLTOVF_F)
C+
C Determine the datatype of the instruction by that of its
C second operand, since that is always the type of the
C destination.
C-
OP_DTYPE = IBITS(OP_TYPES(2),LIB$V_DCFTYP,LIB$S_DCFTYP)
C+
C Get the size of the datatype in words.
C-
OP_SIZE = OP_SIZES (OP_DTYPE)
C+
C Determine the class of instruction and dispatch to the
C appropriate routine.
C-
INST_BYTE = IBITS(OPCODE,0,8) ! Get first byte
IF (INST_BYTE .EQ. ESCD) INST_BYTE = IBITS(OPCODE,8,8)
INST_CLASS = INST_CLASS_TABLE(INST_BYTE)
GO TO (1000,2000,3000,4000,5000,6000),INST_CLASS
C+
C If we get here, the instruction's entry in the
C INST_CLASS_TABLE is zero. This might happen if the instruction was
C a POLYx, or was some other unsupported instruction. Resignal the
C original exception.
C-
FIXUP_ACTION = SS$_RESIGNAL ! Resignal condition to next handler
RETURN ! Return to LIB$DECODE_FAULT
C+
C 1000 - ADDF2, ADDF3, ADDD2, ADDD3, ADDG2, ADDG3, ADDH2, ADDH3
C
C Result's sign is the same as that of the first operand,
C unless this is an underflow, in which case the magnitudes of
C the values may change the sign.
C-
1000 RESULT_NEGATIVE = LIB$EXTV (15,1,%VAL(READ_OPS(1)))
IF (.NOT. OVERFLOW) THEN
IF (SMALLER(OP_SIZE,%VAL(READ_OPS(1)),
1 %VAL(READ_OPS(2))))
2 RESULT_NEGATIVE = .NOT. RESULT_NEGATIVE
END IF
GO TO 9000
C+
C 2000 - SUBF2, SUBF3, SUBD2, SUBD3, SUBG2, SUBG3, SUBH2, SUBH3
C
C Result's sign is the opposite of that of the first operand,
C unless this is an underflow, in which case the magnitudes of
C the values may change the sign.
C-
2000 RESULT_NEGATIVE = .NOT. LIB$EXTV (15,1,%VAL(READ_OPS(1)))
IF (.NOT. OVERFLOW) THEN
IF (SMALLER(OP_SIZE,%VAL(READ_OPS(1)),
1 %VAL(READ_OPS(2))))
2 RESULT_NEGATIVE = .NOT. RESULT_NEGATIVE
END IF
GO TO 9000
C+
C 3000 - MULF2, MULF3, MULD2, MULD3, MULG2, MULG3, MULH2, MULH3,
C DIVF2, DIVF3, DIVD2, DIVD3, DIVG2, DIVG3, DIVH2, DIVH3,
C
C If the signs of the first two operands are the same, then the
C result's sign is positive, if they are not it is negative.
C-
3000 SIGN1 = LIB$EXTV (15,1,%VAL(READ_OPS(1)))
SIGN2 = LIB$EXTV (15,1,%VAL(READ_OPS(2)))
RESULT_NEGATIVE = SIGN1 .XOR. SIGN2
GOTO 9000
C+
C 4000 - ACBF, ACBD, ACBG, ACBH
C
C The result's sign is the same as that of the second operand
C (addend), unless this is underflow, in which case the
C magnitudes of the addend and index may change the sign.
C We must also determine if the branch is to be taken.
C-
4000 SIGN2 = LIB$EXTV (15,1,%VAL(READ_OPS(2)))
RESULT_NEGATIVE = SIGN2
IF (.NOT. OVERFLOW) THEN
IF (SMALLER(OP_SIZE,%VAL(READ_OPS(2)),
1 %VAL(READ_OPS(3))))
2 RESULT_NEGATIVE = .NOT. RESULT_NEGATIVE
END IF
C+
C If this is overflow, then the branch is not taken, since the
C result is always going to be greater or equal in magnitude
C to the limit, and will be the correct sign. If underflow,
C the branch is ALMOST always taken. The only case where the
C branch might not be taken is when the result is exactly
C equal to the limit. For this example, we are going to ignore
C this exceptional case.
C-
IF (.NOT. OVERFLOW)
1 REGISTERS(15) = READ_OPS(4) ! Branch destination
GO TO 9000
C+
C 5000 - CVTDF, CVTGF, CVTHF, CVTHD, CVTHG
C
C Result's sign is the same as that of the first operand.
C-
5000 RESULT_NEGATIVE = LIB$EXTV (15,1,%VAL(READ_OPS(1)))
GO TO 9000
C+
C 6000 - EMODF, EMODD, EMODG, EMODH
C
C If the signs of the first and third operands are the same, then the
C result's sign is positive, else it is negative.
C-
6000 SIGN1 = LIB$EXTV (15,1,%VAL(READ_OPS(1)))
SIGN2 = LIB$EXTV (15,1,%VAL(READ_OPS(3)))
RESULT_NEGATIVE = SIGN1 .XOR. SIGN2
GOTO 9000
C+
C All code paths merge here to store the result value. We also
C set the PSL appropriately. First, determine which operand is
C the result.
C-
9000 RESULT_OP = OP_COUNT
IF (INST_CLASS .EQ. 4)
1 RESULT_OP = RESULT_OP - 1 ! ACBx
C+
C Select result based on datatype and exception type.
C-
IF (OVERFLOW) THEN
CALL LIB$MOVC3 (OP_SIZE,BIGGEST,%VAL(WRITE_OPS(RESULT_OP)))
ELSE
GO TO (9100,9200,9300,9400), OP_DTYPE-(LIB$K_DCFTYP_F-1)
C+
C Should never get here. Resignal original exception.
C-
FIXUP_ACTION = SS$_RESIGNAL
RETURN
C+
C 9100 - F_floating result
C-
9100 CALL LIB$MOVC3 (OP_SIZE,SMALL_F,%VAL(WRITE_OPS(RESULT_OP)))
GOTO 9500
C+
C 9200 - D_floating result
C-
9200 CALL LIB$MOVC3 (OP_SIZE,SMALL_D,%VAL(WRITE_OPS(RESULT_OP)))
GOTO 9500
C+
C 9300 - G_floating result
C-
9300 CALL LIB$MOVC3 (OP_SIZE,SMALL_G,%VAL(WRITE_OPS(RESULT_OP)))
GOTO 9500
C+
C 9400 - H_floating result
C-
9400 CALL LIB$MOVC3 (OP_SIZE,SMALL_H,%VAL(WRITE_OPS(RESULT_OP)))
GOTO 9500
9500 END IF
C+
C Modify the PSL to reflect the stored result. If the result was
C negative, set the N bit. Clear the V (overflow) and Z (zero) bits.
C If the instruction was an ACBx, leave the C (carry) bit unchanged,
C otherwise clear it.
C-
IF (RESULT_NEGATIVE) THEN
PSL = IBSET (PSL,PSL$V_N) ! Set N bit
ELSE
PSL = IBCLR (PSL,PSL$V_N) ! Clear N bit
END IF
PSL = IBCLR (PSL,PSL$V_V) ! Clear V bit
PSL = IBCLR (PSL,PSL$V_Z) ! Clear Z bit
IF (INST_CLASS .NE. 4)
1 PSL = IBCLR (PSL,PSL$V_C) ! Clear C bit if not ACBx
C+
C Set the sign of result.
C-
IF (RESULT_NEGATIVE)
1 CALL LIB$INSV (1,15,1,%VAL(WRITE_OPS(RESULT_OP)))
C+
C Fixup is complete. Return to LIB$DECODE_FAULT.
C-
FIXUP_ACTION = SS$_CONTINUE
RETURN
END
C+
C Function which compares two floating values. It returns .TRUE. if
C the first argument is smaller in magnitude than the second.
C-
LOGICAL*4 FUNCTION SMALLER(NBYTES,VAL1,VAL2)
INTEGER*4 NBYTES ! Number of bytes in values
INTEGER*2 VAL1(*),VAL2(*) ! Floating values to compare
INTEGER*4 WORDA,WORDB
SMALLER = .TRUE. ! Initially return true
C+
C Zero extend to a longword for unsigned compares.
C Compare first word without sign bit.
C-
WORDA = IBCLR(ZEXT(VAL1(1)),15)
WORDB = IBCLR(ZEXT(VAL2(1)),15)
IF (WORDA .LT. WORDB) RETURN
DO I=2,NBYTES/2
WORDA = ZEXT(VAL1(I))
WORDB = ZEXT(VAL2(I))
IF (WORDA .LT. WORDB) RETURN
END DO
SMALLER = .FALSE. ! VAL1 not smaller than VAL2
RETURN
END
|