Macintosh-SW/mac-rom
1
0
Fork 0
mirror of https://github.com/elliotnunn/mac-rom.git synced 2025-01-04 01:29:22 +00:00
Code Issues Projects Releases Wiki Activity
10e586a0ec
mac-rom/Toolbox/InSANE/FPCTRL.a

1210 lines
32 KiB
Plaintext
Raw Normal View History

Bring in CubeE sources Resource forks are included only for .rsrc files. These are DeRezzed into their data fork. 'ckid' resources, from the Projector VCS, are not included. The Tools directory, containing mostly junk, is also excluded.
2017-09-17 09:09:04 +00:00
;
; File: FPCTRL.a
;
; Contains: xxx put contents here xxx
;
; Written by: xxx put writers here xxx
;
; Copyright: <09> 1990 by Apple Computer, Inc., all rights reserved.
;
; This file is used in these builds: Mac32
;
; Change History (most recent first):
;
; Terror Change History:
;
; <1> 11/14/90 BG Added to BBS for the first time.
;
; To Do:
;
;-----------------------------------------------------------
; FPCONTROL for MC68020
; Copyright Apple Computer, Inc., 1983,1984,1985,1989,1990
; All rights reserved
;-----------------------------------------------------------
;-----------------------------------------------------------
; 9 JAN 90: WRITTEN BY JON OKADA FOR MC68020, BASED UPON
; LISA CODE BY JEROME COONEN
; 11 JUN 90: MODIFIED TO SUPPORT 96-BIT EXTENDED OPERANDS (JPO)
;-----------------------------------------------------------
;-----------------------------------------------------------
; This is the main entry point of the package. The stack has
; the form:
; ret < opword < addr1 < addr2 < addr3,
; where the number of addresses (1, 2, or 3) depends on the
; operation.
;
; Dispatching is done to entry points for individual operations
; or for groups of similar operations.
;-----------------------------------------------------------
FP020 PROC EXPORT
;-----------------------------------------------------------
; Prepare for quick dispatching for operations
;-----------------------------------------------------------
; dc.w $a9ff
SUBQ.L #4,SP ; space for dispatching via RTS
MOVEM.L D0/A0,-(SP) ; save minimum # of registers
;-----------------------------------------------------------
; Get opword into D0.LO and dispatch quickly if format is
; extended or opword is odd.
;-----------------------------------------------------------
DISPBASE:
MOVEQ #0,D0 ; zero D0
MOVE.W 16(SP),D0 ; D0.W <- opcode
BFTST D0{18:3} ; test operation format:
BEQ.S DISP1 ; quick dispatch if extended
BTST #0,D0 ; test opcode for odd/even:
BEQ.S DISP2 ; even case uses second dispatch table
;-----------------------------------------------------------
; Dispatch via table for extended format or odd-numbered operations
;-----------------------------------------------------------
DISP1:
ANDI.W #$001F,D0 ; D0.W <- operation index
ADD D0,D0 ; double index to obtain table index
MOVE.W D1CASE(D0),D0 ; D0 <- operation addr offset
LEA DISPBASE(D0),A0 ; A0 <- operation addr
;-----------------------------------------------------------
; Accomplish entry to routine address in A0 via RTS. At this
; point, stack is:
; (SAVED D0/A0) < longword for addr < ret < opword < arg addresses
;-----------------------------------------------------------
VECTOROFF:
MOVE.L A0,8(SP) ; stuff addr in A0 into stack
MOVEM.L (SP)+,D0/A0 ; restore two registers
RTS ; quick entry to implementation
;-----------------------------------------------------------
; Dispatch via table for remaining even-numbered operations
;-----------------------------------------------------------
DISP2:
ANDI.W #$001E,D0 ; D0.W <- table index
MOVE.W D2CASE(D0),D0 ; D0 <- operation addr offset
LEA DISPBASE(D0),A0 ; A0 <- operation addr
BRA.S VECTOROFF ; dispatch after restoring registers
;-----------------------------------------------------------
; Tables for dispatching to operations
;-----------------------------------------------------------
D1CASE:
DC.W QADDX - DISPBASE
DC.W QSETENV - DISPBASE
DC.W QSUBX - DISPBASE
DC.W QGETENV - DISPBASE
DC.W QMULX - DISPBASE
DC.W QSETHV - DISPBASE
DC.W QDIVX - DISPBASE
DC.W QGETHV - DISPBASE
DC.W QCMPX - DISPBASE
DC.W QD2B - DISPBASE
DC.W QCMPX - DISPBASE
DC.W QB2D - DISPBASE
DC.W QREMX - DISPBASE
DC.W QNEG - DISPBASE
DC.W QX2X - DISPBASE
DC.W QABS - DISPBASE
DC.W QX2X - DISPBASE
DC.W QCPYSGN - DISPBASE
DC.W QSQRTX - DISPBASE
DC.W QNEXTB - DISPBASE
DC.W QRINTX - DISPBASE
DC.W QSETXCP - DISPBASE
DC.W QTINTX - DISPBASE
DC.W QPROCENTRY- DISPBASE
DC.W QSCALBX - DISPBASE
DC.W QPROCEXIT - DISPBASE
DC.W QLOGBX - DISPBASE
DC.W QTESTXCP - DISPBASE
DC.W QCLASSX - DISPBASE
D2CASE:
DC.W QADDB - DISPBASE
DC.W QSUBB - DISPBASE
DC.W QMULB - DISPBASE
DC.W QDIVB - DISPBASE
DC.W QCMPB - DISPBASE
DC.W QCMPB - DISPBASE
DC.W QREMB - DISPBASE
DC.W QB2X - DISPBASE
DC.W QX2B - DISPBASE
DC.W QSQRTX - DISPBASE
DC.W QRINTX - DISPBASE
DC.W QTINTX - DISPBASE
DC.W QSCALBX - DISPBASE
DC.W QLOGBX - DISPBASE
DC.W QCLASSB - DISPBASE
;-----------------------------------------------------------
;-----------------------------------------------------------
; Code to store opword and unpack pairs of operands, assuming
; A6 link entry. Register usage:
; A0 continuation jmp address
; A3 DST exponent
; A4 SRC exponent
; D0 operand classification
; D3/A2 DST significand
; D4/D5 SRC significand
; D6 opword/exceptions/operand signs
; D7 round/stickies (initialized to zero)
; A1/D1 scratch
;
; D6 will contain the following information:
; opword in bits 16-31 (HI word)
; exceptions in bits 8-12 (initialized to zero)
; SRC sign in bit 7
; DST sign in bit 6
; XOR of signs in bit 5
;
; D0 low word will contain NaN information for easy dispatching:
; 0 neither operand is a NaN
; 2 SRC is a NaN
; 4 DST is a NaN
; 6 both operands are NaNs
;
; If the low word in D0 is zero, the high word contains further
; classification information:
; 0 both operands are finite nonzero numbers
; 2 DST is finite and nonzero; SRC is zero
; 4 DST is finite and nonzero; SRC is infinite
; 6 DST is zero; SRC is finite and nonzero
; 8 both operands are zero
; 10 DST is zero; SRC is infinite
; 12 DST is infinite; SRC is finite and nonzero
; 14 DST is infinite; SRC is zero
; 16 both operands are infinite
; In this case (no NaN input, the high and low words of D0 are
; swapped before the operation continues.
;-----------------------------------------------------------
;-----------------------------------------------------------
;-----------------------------------------------------------
; Extended SRC and DST
;-----------------------------------------------------------
UNPACKXX:
MOVE.W LKOP(A6),D6 ; get opword into D6.HI
MOVEQ #0,D0 ; and zero D0
SWAP D6
CLR.W D6 ; zero D6.LO
MOVEA.L LKADR1(A6),A1 ; unpack extended DST
BSR UNPXOP
MOVEA.L A4,A3 ; move to A3/D3/A2
MOVE.L D4,D3
MOVEA.L D5,A2
LSR.B #1,D6 ; move sign to D6 bit 6
MOVE.L D0,D1 ; double NaN index (D0.LO) and
CLR.W D1
ADD.L D0,D0 ; and triple number index (D0.HI)
ADD.L D1,D0
MOVEA.L LKADR2(A6),A1 ; unpack extended SRC
BSR UNPXOP
;-----------------------------------------------------------
; Convenient to put XOR of signs in D6 bit 5
;-----------------------------------------------------------
UNPACKED2:
ASL.B #1,D6 ; V = XOR of signs
BVC.S @1
BSET #6,D6
@1:
ROXR.B #1,D6
MOVEQ #0,D7 ; zero D7
;-----------------------------------------------------------
; Branch to special code if NaN(s) unpacked
;-----------------------------------------------------------
TST.W D0 ; any NaN input?
BNE.S NAN2OPS ; yes; special processing
SWAP D0 ; no; swap D0 high/low
JMP (A0) ; do operation
;-----------------------------------------------------------
; Non-extended SRC and extended DST
;-----------------------------------------------------------
UNPACKXB:
MOVE.W LKOP(A6),D6 ; Get opword into D6.HI
MOVEQ #0,D0 ; and zero D0
SWAP D6
CLR.W D6 ; zero D6.LO
MOVEA.L LKADR1(A6),A1 ; unpack extended DST
BSR UNPXOP
MOVEA.L A4,A3 ; move to A3/D3/A2
MOVE.L D4,D3
MOVEA.L D5,A2
LSR.B #1,D6 ; move sign to D6 bit 6
MOVE.L D0,D1 ; double NaN index (D0.LO) and
CLR.W D1
ADD.L D0,D0 ; and triple number index (D0.HI)
ADD.L D1,D0
MOVE.L D6,D1 ; extract offset from format
CLR.W D1 ; code in opword
ROL.L #6,D1
ANDI.W #$000E,D1
SUBQ.W #2,D1
MOVEA.L LKADR2(A6),A1 ; unpack non-extended SRC
BSR UNPBOP
BRA.S UNPACKED2 ; get XOR of signs & check for NaNs
;-----------------------------------------------------------
; This is the target of all invalid operations with extended
; results. Bits in D0 000000XX must go to 00XX0000.
;-----------------------------------------------------------
INVALIDOP:
BSET #ERRI+8,D6
SWAP D0 ; align code byte
BSET #QNANBIT,D0 ; mark it quiet
MOVE.L D0,D4
MOVEQ #0,D5 ; clear low half
MOVEA.W #$7FFF,A4 ; set exponent
BRA PACKX ; pack it
;-----------------------------------------------------------
; NaN input detected for binary operation. Take as preliminary
; result any single NaN input or, if both inputs are NaN, the
; NaN with the larger code. At this point, unpacked extended
; operands are in A3/D3/A2 (DST) and A4/D4/D5 (SRC), and the
; input NaN flags are in D0.W.
;-----------------------------------------------------------
NAN2OPS:
LEA FINI2OPS,A0 ; continuation addr
NANCOMMON:
SUBQ.W #2,D0
BEQ.S NANSRC ; SRC NaN only
SUBQ.W #2,D0
BEQ.S NANDST ; DST NaN only
MOVE.L D3,D7 ; two NaN inputs
MOVE.L #$00FF0000,D1 ; NaN code mask
AND.L D1,D7 ; DST code
AND.L D4,D1 ; SRC code
CMP.L D7,D1
BGT.S NANSRC ; SRC code >= DST code
NANDST: ; move DST NaN to SRC position
ADD.B D6,D6 ; sign
MOVEA.L A3,A4 ; exponent
MOVE.L D3,D4 ; significand
MOVE.L A2,D5
NANSRC:
BFEXTU D6{11:5},D1 ; D1 <- opcode
SUBQ #8,D1
BEQ.S NANCMP ; FCMP opcode (no signal on unordered)
SUBQ #2,D1
BNE.S FPNANOUT ; output extended NaN
BSET #ERRI+8,D6 ; FCPX signals invalid on unordered
NANCMP:
MOVEQ #CMPU,D7 ; mark unordered
BRA FINICMPS ; finish comparison
;-----------------------------------------------------------
; Output extended NaN after checking for interesting NaN bits,
; giving special code if there is none
;-----------------------------------------------------------
FPNANOUT:
BSR.S FPNANIN ; check for interesting NaN bits
BRA PACKX ; stuff NaN result
;-----------------------------------------------------------
; Subroutine FPNANIN checks for interesting NaN bits and gives
; a special NaN code if there is none. Input NaN significand
; is in D4/D5. Uses D1 as scratch register
;-----------------------------------------------------------
FPNANIN:
MOVE.L D4,D1 ; check for all zeros
BCLR #QNANBIT,D1 ; disregard quiet bit
OR.L D5,D1
BNE.S @1
MOVEQ #NANZERO,D4 ; special NaN if no code
SWAP D4
BSET #QNANBIT,D4
@1:
RTS
;-----------------------------------------------------------
; Subroutine UNPXOP unpacks an extended operand. Register usage
; is as follows:
; ENTRY:
; A1 operand addr
; D6.HI opword (includes 96-bit extended format bit (#21)
; EXIT:
; A4 exponent of operand sign-extended to 32 bits
; D4/D5 extended significand
; D0 classification code for operand (ADDed in)
; D6 sign of operand in bit 7 (ORed in)
; A1,D1 trashed
;-----------------------------------------------------------
UNPXOP:
MOVE.W (A1)+,D1 ; D1 <- sign/exp
BPL.S @1 ; + case
BSET #7,D6 ; - case; set flag in D6
BCLR #15,D1 ; and clr sign bit
@1:
BTST #21,D6 ; 96-bit extended?
BEQ.S @2 ; no. 80-bit
ADDQ #2,A1 ; yes. bump pointer by 2
@2:
MOVE.L (A1)+,D4 ; significand bits into D4/D5
MOVE.L (A1),D5
CMPI.W #$7FFF,D1 ; max exp?
BEQ.S UNPNIN ; yes; special handling
TST.L D4 ; normalized?
BPL.S UNPZUN ; no; special handling
UNPNRM: ; normalized case
EXT.L D1 ; 32-bit exponent in A4
MOVEA.L D1,A4
RTS ; return
;-----------------------------------------------------------
; Distinguish special case and set appropriate bit in D0:
; bit 17 for zero;
; bit 18 for infinite
; bit 1 for NaN
;-----------------------------------------------------------
UNPZUN:
TST.L D4 ; unnormalized or zero
BNE.S UNPUNR
TST.L D5
BNE.S UNPUNR ; do normalization
UNP0:
SUBA.L A4,A4 ; ZERO unpacked; zero exponent
ADD.L #$00020000,D0 ; mark in D0
RTS ; done
UNPUNR: ; enter here to normalize quietly
SUBQ.W #1,D1 ; decrement exponent
ADD.L D5,D5 ; shift significand left
ADDX.L D4,D4
BPL.S UNPUNR ; loop until high bit of D4 set, then
BRA.S UNPNRM ; treat as normalized
UNPNIN: ; NaN or infinity
MOVEA.W #$7FFF,A4 ; max exponent
BCLR #31,D4 ; ignore explicit bit
TST.L D4
BNE.S UNPNAN ; NaN if any other significand
TST.L D5 ; bit is set
BNE.S UNPNAN
ADD.L #$00040000,D0 ; INFINITE; mark INF operand in D0
RTS
;-----------------------------------------------------------
; NaN unpacked. Test and set the quiet NaN bit (#30 of upper
; half of the significand); if it was clear, then signal invalid.
;-----------------------------------------------------------
UNPNAN:
BSET #QNANBIT,D4 ; quiet the NaN
BNE.S @2 ; it was already quiet
BSET #ERRI+8,D6 ; signaling NaN raises invalid flag
@2:
ADDQ.W #2,D0 ; mark NaN in D0
RTS
;-----------------------------------------------------------
; Subroutine UNPBOP unpacks a non-extended binary operand. Register
; usage is as follows:
; ENTRY:
; A1 operand addr
; D1 offset into jump table for unpack routine
; EXIT:
; A4 exponent of operand sign-extended to 32 bits
; D4/D5 extended significand
; D0 classification code for operand (ADDed in)
; D6 sign of operand in bit 7 (ORed in)
; A1,D1 trashed
; D2 scratch register for some formats
;-----------------------------------------------------------
UNPBOP:
MOVE.W UNPCASE(D1),D1 ; get addr of specific routine
JMP UNPBOP(D1) ; and jump there
UNPCASE:
DC.W UNPDBL - UNPBOP ; double precision
DC.W UNPSGL - UNPBOP ; single precision
DC.W UNPXOP - UNPBOP ; ---illegal format
DC.W UNPI16 - UNPBOP ; int16
DC.W UNPI32 - UNPBOP ; int32
DC.W UNPC64 - UNPBOP ; comp
;-----------------------------------------------------------
; 16-bit integer unpacking has special case of zero; else
; normalize and return
;-----------------------------------------------------------
UNPI16:
MOVEQ #0,D4 ; zero D4
MOVE.W #$400E,D1 ; set exponent for short integer
MOVE.L D4,D5 ; zero D5
MOVE.W (A1),D4 ; get operand
SWAP D4 ; left align in register
BRA.S UNPIGEN ; continue below
;-----------------------------------------------------------
; 32-bit integer unpacking has special case of zero; else
; normalize and return
;-----------------------------------------------------------
UNPI32:
MOVE.W #$401E,D1 ; set exponent for long integer
MOVEQ #0,D5 ; zero D5
MOVE.L (A1),D4 ; get operand
UNPIGEN:
BEQ.S UNP0 ; zero
BPL.S UNPIUNR ; positive. normalize
BSET #7,D6 ; negative. set sign in D6
NEG.L D4 ; negate D4
BMI.S UNPNRM ; already normalized if = $80000000
;-----------------------------------------------------------
; Normalization for D4 > 0 and D5 = 0
;-----------------------------------------------------------
UNPIUNR:
BFFFO D4{0:0},D2 ; find first one bit
SUB.W D2,D1 ; adjust exponent
LSL.L D2,D4 ; shift significand
BRA UNPNRM ; NORMALIZED
;-----------------------------------------------------------
; 64-bit comp unpacking has special cases of zero and NaN; else
; normalize and return
;-----------------------------------------------------------
UNPC64:
MOVE.W #$403E,D1 ; initialize exponent
MOVE.L (A1)+,D4 ; get operand into D4/D5
MOVE.L (A1),D5
BNE.S @1 ; low half nonzero
TST.L D4 ; test high half
BEQ UNP0 ; comp ZERO
BPL.S UNPIUNR ; normalize positive
BSET #7,D6 ; flag negative in D6
NEG.L D4 ; negate high significand
BPL.S UNPIUNR ; normalize if not NaN
MOVEA.W #$7FFF,A4 ; comp NaN; set exponent
BCLR #7,D6 ; clear sign bit
MOVEQ #NANCOMP,D4 ; NaN code in significand high word
SWAP D4
BSET #QNANBIT,D4 ; make it quiet
ADDQ.W #2,D0 ; mark NaN in D0
RTS ; done
@1: ; comp low half nonzero
TST.L D4 ; test high half
BPL.S @2 ; nonnegative
BSET #7,D6 ; mark as negative in D6
NEG.L D5 ; negate
NEGX.L D4
TST.L D4 ; test high half
@2:
BNE UNPUNR ; nonzero; normalize D4/D5
SUBI.W #$0020,D1 ; high half zero; reduce exponent
EXG D4,D5 ; exchange high/low halves
TST.L D4
BPL.S UNPIUNR ; normalize if necessary
BRA UNPNRM
;-----------------------------------------------------------
; Single-precision unpacking has special cases of zero, NaN,
; and infinite
;-----------------------------------------------------------
UNPSGL:
MOVEQ #0,D5 ; zero significand low half
MOVE.L (A1),D4 ; read single-precision into D4
BPL.S @3 ; not negative
BSET #7,D6 ; negative; mark in D6
@3:
BFEXTU D4{1:8},D1 ; extract exponent into D1
BEQ.S @4 ; ZERO or subnormal single
LSL.L #8,D4 ; shift significand just short of bit 31
CMPI.B #$FF,D1 ; max exp?
BEQ UNPNIN ; yes; NaN or INFINITE
ADDI.W #$3F80,D1 ; normalized; bias exponent
BSET #31,D4 ; set explicit bit
BRA UNPNRM
@4:
LSL.L #8,D4 ; shift significand
BEQ UNP0 ; ZERO
MOVE.W #$3F81,D1 ; single subnormal; bias exponent
BRA UNPIUNR ; normalize
;-----------------------------------------------------------
; Double-precision unpacking has special cases of zero, NaN,
; and infinite
;-----------------------------------------------------------
UNPDBL:
MOVE.L (A1),D4 ; high bits into D4
BPL.S @5
BSET #7,D6 ; set sign in D6
@5:
MOVE.L 4(A1),D5 ; low bits in D5
;-----------------------------------------------------------
; Double operands appear as: (1) (11) (1 implicit) (52), so
; must align bits left by 11 places and insert explicit lead
; bit. Do this via shifts and bit field instructions.
;-----------------------------------------------------------
BFEXTU D4{1:11},D1 ; extract exponent into D1
BFEXTU D5{0:11},D2 ; extract 11 high bits of D5
LSL.L #8,D4 ; shift D4 and D5 left 11 places
LSL.L #8,D5
LSL.L #3,D4
LSL.L #3,D5
OR.W D2,D4 ; move 11 bits to D4 low end
BCLR #31,D4 ; clr explicit bit initially
TST.L D1 ; test exponent
BNE.S @6 ; normalized, infinite, or NaN
MOVE.W #$3C01,D1 ; zero or unnormalized
BRA UNPZUN
@6:
CMPI.W #$07FF,D1 ; max exp?
BEQ UNPNIN ; yes, NaN or INF
BSET #31,D4 ; normalized number; set explicit bit
ADDI.W #$3C00,D1 ; bias exponent
BRA UNPNRM
;-----------------------------------------------------------
; Subroutine RTSHIFT.
;
; This is the right shifter used in subnormal coercion, IPALIGN ...
; Shift count in D0 > 0; Shift registers are D4/D5/D7 (stickies)
; Uses D3 as scratch register.
;-----------------------------------------------------------
RTSHIFT:
CMPI.W #66,D0 ; high shift counts pin to 66
BLS.S @1
MOVE.W #66,D0
@1:
CMPI.W #32,D0 ; count < 32?
BLT.S @3 ; yes. do shift
TST.L D7 ; no. set stickies if D7 nonzero
SNE D3
MOVE.L D5,D7 ; shift D4/D5 into D5/D7
MOVE.L D4,D5
OR.B D3,D7 ; OR in low stickies
MOVEQ #0,D4 ; zero D4
SUBI.W #32,D0 ; decr count by 32
BNE.S @1 ; loop if nonzero
RTS ; otherwise, done
@3: ; right shift of 1-31 bits
BFINS D7,D3{0:D0} ; test low bits
SNE D3 ; set sticky state in D3
LSR.L D0,D7 ; shift D7 right
BFINS D5,D7{0:D0} ; shift bits from D5 low to D7 high
LSR.L D0,D5 ; shift D5 right
BFINS D4,D5{0:D0} ; shift bits from D4 low to D5 high
LSR.L D0,D4 ; shift D4
OR.B D3,D7 ; OR in low stickies
RTS ; done
;-----------------------------------------------------------
; COERCION routines assume post-operation register mask with
; result in:
; A4 exponent
; D4 significand high 32 bits
; D5 significand
; D7 round/stickies.
;-----------------------------------------------------------
;-----------------------------------------------------------
; Check value first, stuff if zero (with exp fix), otherwise,
; normalize and coerce. Called only by remainder routine,
; which is exact and which has default (extended) rounding
; precision.
;-----------------------------------------------------------
ZNORMCOERCEX:
MOVE.L #0,D7 ; make it exact
TST.L D4
BNE.S NORMX ; nonzero
TST.L D5
BNE.S NORMX ; nonzero
SUBA.L A4,A4 ; zero
BRA PACKX ; never coerce
NORMX:
TST.L D4 ; check for lead 1 bit
BMI COERCEX ; normalized, so coerce
@1:
SUBQ.L #1,A4 ; decr exponent
ADD.L D5,D5 ; shift significand
ADDX.L D4,D4
BPL.S @1 ; loop until normalized
BRA COERCEX ; coerce with default precision
;-----------------------------------------------------------
; ASSUME, AS AFTER SUBTRACT THAT VALUE IS NONZERO. USE 1ST
; BRANCH TO SHORTEN ACTUAL LOOP BY A BRANCH.
;-----------------------------------------------------------
NORMCOERCE:
TST.L D4 ; CHECK FOR LEAD 1
BMI.S COERCE
@1:
SUBQ.L #1,A4 ; DECREMENT EXP
ADD.L D7,D7 ; SHIFT RND
ADDX.L D5,D5 ; LO BITS
ADDX.L D4,D4
BPL.S @1 ; WHEN NORM, FALL THROUGH
;-----------------------------------------------------------
; COERCE MILESTONE +++++++++++++++++++++++++++++++++++++++ .
;
; RUN SEPARATE SEQUENCES FOR EXT, SGL, DBL TO SAVE TESTS.
; NOTE THAT FOR CONVENIENCE IN BRANCHING, THE SGL AND DBL
; COERCE SEQUENCES FOLLOW THE COERCE ROUTINES.
; SINCE OVERFLOW RESULTS IN A VALUE DEPENDING ON THE
; PRECISION CONTROL BITS, RETURN CCR KEY FROM OFLOW:
; EQ: OK NE: HUGE
;
; Extended result is in D6 bit 7 (sign), A4 (exp), D4/D5 (sig),
; and D7 (round/stickies).
; Uses D1.W to store environment word for rounding control info.
;-----------------------------------------------------------
COERCE:
MOVE.W (FPSTATE).W,D1 ; environment in D1
BFTST D1{25:2} ; check rounding precision
BEQ COERCEX ; default (extended)
BPL COERCED ; double
;-----------------------------------------------------------
; Coerce to single precision, obeying prescribed
; rounding direction.
;-----------------------------------------------------------
COERCES:
BSR.S SCOERCE ; coerce to single precision
BRA COERCESDONE
;-----------------------------------------------------------
; Subroutine SCOERCE coerces extended value in A4/D4/D5/D7 to
; single precision, honoring prescribed rounding direction
; in environment word (D1.W). Uses D0, clobbers D1
;-----------------------------------------------------------
SCOERCE:
MOVE.L #$3F81,D0 ; single underflow threshold
SUB.L A4,D0 ; threshold - exponent
BLE.S @1 ; no underflow
BSET #ERRU+8,D6 ; signal underflow
MOVEA.W #$3F81,A4 ; minimum exponent
BSR RTSHIFT ; shift
@1:
TST.L D5 ; get single precision bits/stickies
SNE D0 ; nonzero D5 sets low stickies
OR.B D0,D7
ADD.B D4,D4 ; round bit to X
ROXR.L #1,D7 ; X to D7 high bit
OR.B D4,D7 ; last stickies to D7 low byte
MOVEQ #0,D5 ; clear low bits
CLR.B D4
TST.L D7 ; exact result?
BNE.S @3 ; no
BCLR #ERRU+8,D6 ; yes. suppress underflow
BRA.S RNDOVERS
@3:
BSET #ERRX+8,D6 ; signal inexact
BFTST D1{17:2} ; round to nearest?
BEQ.S @7 ; yes
BMI.S @5 ; chop or round downward
TST.B D6 ; round toward +<2B>
BPL.S RNDUPS ; increment significand if positive
BRA.S RNDOVERS
@5:
BTST #13,D1 ; chop or round toward -<2D>
BNE.S RNDOVERS ; chop requires no incrementing
TST.B D6 ; round toward -<2D>
BPL.S RNDOVERS
BRA.S RNDUPS ; increment significand if negative
@7:
ADD.L D7,D7 ; round bit set?
BCC.S RNDOVERS ; no; significand OK
BNE.S RNDUPS ; yes, with stickies, so round up
BTST #8,D4 ; halfway case gets bumped if low single
BEQ.S RNDOVERS ; bit is set
RNDUPS:
ADD.L #$0100,D4 ; bump significand
BCC.S RNDOVERS
ROXR.L #1,D4 ; if overflow, shift right and bump exponent
ADDQ.L #1,A4
RNDOVERS:
MOVEA.W #$407E,A3 ; single overflow exponent threshold
CMPA.L A4,A3
BLT.S @9
RTS ; no overflow
@9: ; single precision overflow
BSET #ERRO+8,D6 ; signal overflow and inexact
BSET #ERRX+8,D6
MOVEA.W #$7FFF,A4 ; store INF initially
SUB.L D4,D4
SUB.L D5,D5
LSR.W #8,D1 ; check rounding direction
AND.B #RNDMSK,D1
BNE.S @11
RTS ; default rounding returns INF
@11:
CMPI.B #RNDMSK,D1 ; chopping returns single HUGE
BEQ.S HUGES
TST.B D6 ; check sign
BMI.S @15
CMPI.B #RNDUP,D1 ; positive
BNE.S HUGES ; round down returns single HUGE
RTS ; round up returns INF
@15:
CMPI.B #RNDDN,D1 ; negative
BNE.S HUGES ; round up returns single HUGE
RTS ; round down returns -INF
HUGES:
MOVEQ #-1,D4 ; set maximum single exponent and significand
MOVEA.L A3,A4
CLR.B D4
RTS
;-----------------------------------------------------------
; Coerce to double precision, obeying prescribed
; rounding direction.
;-----------------------------------------------------------
COERCED:
BSR.S DCOERCE ; coerce to double precision
COERCESDONE:
BTST #ERRU+8,D6 ; underflow?
BEQ PACKX ; no; pack extended format
MOVE.W A4,D3 ; zero exponent?
BEQ PACKX ; yes; OK
TST.L D4 ; normalized or nonzero?
BNE.S @3 ; yes
TST.L D5
BNE.S @1 ; unnormalized
SUBA.L A4,A4 ; zero (inexact result); zero exponent
BRA PACKX ; pack extended format
@1:
SUBA.W #1,A4 ; normalize subnormal single/double
ADD.L D5,D5
ADDX.L D4,D4
@3:
BPL.S @1
BRA PACKX ; pack extended format
;-----------------------------------------------------------
; Subroutine DCOERCE coerces extended value in A4/D4/D5/D7 to
; double precision, honoring prescribed rounding direction
; in environment word (D1.W). Uses D0/D2/A3, clobbers D1
;-----------------------------------------------------------
DCOERCE:
MOVE.L #$3C01,D0 ; double underflow threshold
SUB.L A4,D0 ; threshold - exponent
BLE.S @1 ; no underflow
BSET #ERRU+8,D6 ; signal underflow
MOVEA.W #$3C01,A4 ; minimum exponent
BSR RTSHIFT ; shift
@1:
MOVE.L #$07FF,D0 ; low bit mask
AND.W D5,D0
ANDI.W #$0F800,D5 ; clr low bits
LSL.W #5,D0 ; left align round/stickies
SWAP D0
TST.L D7 ; stickies from D7
SNE D0
MOVE.L D0,D7 ; round/stickies into D7
TST.L D7 ; exact result?
BNE.S @3 ; no
BCLR #ERRU+8,D6 ; yes. suppress underflow
BRA.S RNDOVERD
@3:
BSET #ERRX+8,D6 ; signal inexact
BFTST D1{17:2} ; round to nearest?
BEQ.S @7 ; yes
BMI.S @5 ; chop or round downward
TST.B D6 ; round toward +<2B>
BPL.S RNDUPD ; increment significand if positive
BRA.S RNDOVERD
@5:
BTST #13,D1 ; chop or round toward -<2D>
BNE.S RNDOVERD ; chop requires no incrementing
TST.B D6 ; round toward -<2D>
BPL.S RNDOVERD
BRA.S RNDUPD ; increment significand if negative
@7:
ADD.L D7,D7 ; round bit set?
BCC.S RNDOVERD ; no; significand OK
BNE.S RNDUPD ; yes, with stickies, so round up
BTST #11,D5 ; halfway case gets bumped if low double
BEQ.S RNDOVERD ; bit is set
RNDUPD:
MOVEQ #0,D0
MOVE.L #$00000800,D2
ADD.L D2,D5 ; bump significand
ADDX.L D0,D4
BCC.S RNDOVERD
ROXR.L #1,D4 ; if overflow, shift right and bump exponent
ADDQ.L #1,A4
RNDOVERD:
MOVEA.W #$43FE,A3 ; double overflow exponent threshold
CMPA.L A4,A3
BLT.S @9
RTS ; no overflow
@9: ; double precision overflow
BSET #ERRO+8,D6 ; signal overflow and inexact
BSET #ERRX+8,D6
MOVEA.W #$7FFF,A4 ; store INF initially
SUB.L D4,D4
SUB.L D5,D5
LSR.W #8,D1 ; check rounding direction
AND.B #RNDMSK,D1
BNE.S @11
RTS ; default rounding returns INF
@11:
CMPI.B #RNDMSK,D1 ; chopping returns double HUGE
BEQ.S HUGED
TST.B D6 ; check sign
BMI.S @15
CMPI.B #RNDUP,D1 ; positive
BNE.S HUGED ; round down returns double HUGE
RTS ; round up returns INF
@15:
CMPI.B #RNDDN,D1 ; negative
BNE.S HUGED ; round up returns double HUGE
RTS ; round down returns -INF
HUGED:
MOVEQ #-1,D4 ; set maximum double exponent and significand
MOVEA.L A3,A4
MOVE.L #$FFFFF800,D5
RTS
;-----------------------------------------------------------
; Coerce to default (extended) precision, obeying prescribed
; rounding direction.
;-----------------------------------------------------------
COERCEX:
MOVE.L A4,D0 ; exponent >= 0?
BPL.S ROUNDX ; yes, not subnormal
NEG.L D0 ; underflow; get count
BSET #ERRU+8,D6 ; signal underflow
SUBA.L A4,A4 ; zero exponent
BSR RTSHIFT ; shift significand right
ROUNDX:
TST.L D7 ; exact result?
BNE.S @1 ; no
BCLR #ERRU+8,D6 ; yes; suppress underflow
BRA.S RNDOVERX ; no rounding needed
;-----------------------------------------------------------
; Inexact result: signal and round
;-----------------------------------------------------------
@1:
BSET #ERRX+8,D6 ; signal inexact
BFTST D1{17:2} ; round to nearest?
BEQ.S @3 ; yes
BMI.S @2 ; chop or round downward
;-----------------------------------------------------------
; Round toward +<2B>
;-----------------------------------------------------------
TST.B D6 ; bump significand if positive
BPL.S RNDUPX
BRA.S RNDOVERX
@2:
BTST #13,D1 ; chop or round downward?
BNE.S RNDOVERX ; chop requires no rounding
;-----------------------------------------------------------
; Round toward -<2D>
;-----------------------------------------------------------
TST.B D6 ; bump significand if negative
BPL.S RNDOVERX
BRA.S RNDUPX
;-----------------------------------------------------------
; Default rounding (to nearest)
;-----------------------------------------------------------
@3:
ADD.L D7,D7 ; round bit set?
BCC.S RNDOVERX ; no; significand OK
BNE.S RNDUPX ; stickies set so round up
BTST #0,D5 ; halfway case gets bumped
BEQ.S RNDOVERX ; if lowest SIG bit is 1
RNDUPX:
MOVEQ #0,D0 ; increment significand
ADDQ.L #1,D5
ADDX.L D0,D4
BCC.S RNDOVERX
ROXR.L #1,D4 ; if overflow, shift right and
ADDQ.L #1,A4 ; bump exponent
;-----------------------------------------------------------
; Check for overflow result
;-----------------------------------------------------------
RNDOVERX:
MOVEA.W #$7FFF,A3 ; overflow?
CMPA.L A3,A4
BLT.S PACKX ; no; stuff result
;-----------------------------------------------------------
; Overflow detected. Return HUGE or INF depending on
; rounding direction and sign.
;-----------------------------------------------------------
BSET #ERRO+8,D6 ; signal overflow and inexact
BSET #ERRX+8,D6
MOVEA.W A3,A4 ; set max exp
SUB.L D4,D4 ; zero significand
SUB.L D5,D5
LSR.W #8,D1 ; check rounding direction
AND.B #RNDMSK,D1
BEQ.S PACKX ; default returns INF
CMPI.B #RNDMSK,D1 ; chopping returns HUGE
BEQ.S HUGEOUT
TST.B D6 ; check sign
BMI.S @5
CMPI.B #RNDUP,D1 ; positive
BEQ.S PACKX ; round up returns INF
BRA.S HUGEOUT ; round down returns huge
@5:
CMPI.B #RNDDN,D1 ; negative
BEQ.S PACKX ; round down returns INF
HUGEOUT:
SUBQ #1,A4 ; exponent = $7FFE
NOT.L D4 ; set all significand bits
NOT.L D5
;-----------------------------------------------------------
; Pack an extended result into destination address
;-----------------------------------------------------------
PACKX:
MOVE.W A4,D3 ; exponent into D3
MOVEA.L LKADR1(A6),A3 ; get DST addr
TST.B D6 ; sign into D3
BPL.S @1 ; positive
BSET #15,D3 ; negative
@1:
MOVE.W D3,(A3)+ ; stuff result
BTST #21,D6 ; bump pointer if 96-bit extended
BEQ.S @2
ADDQ #2,A3
@2:
MOVE.L D4,(A3)+
MOVE.L D5,(A3)
JMP (A0) ; finish-up routine
;-----------------------------------------------------------
; Finish up and return after stack cleanup. Check for halts here.
;-----------------------------------------------------------
FINI2OPS:
CLR D7 ; clear CCR bits
FINICMPS:
MOVEA.W #FPSTATE,A1 ; A1 <- environment addr
MOVE.W (A1),D0 ; get environment word
CLR.B D6 ; kill signs
OR.W D6,D0 ; OR in new exceptions
MOVE.W D0,(A1)+ ; store new exceptions and bump A1 pointer
LSR.W #8,D6 ; align exceptions with trap enables
AND.W D6,D0
BNE.S HALT2OP ; halt enabled
FINISH2:
MOVE D7,CCR ; prepare CCR
MOVEM.L (SP)+,D0-D7/A0-A4 ; restore registers
UNLK A6 ; unlink
RTD #STKREM2 ; return, popping parameters
;-----------------------------------------------------------
; TO SET UP FOR TRAP:
; HAVE D0 ON TOP OF STACK.
; PUSH CCR TO HAVE 3-WORD STRUCTURE
; PUSH ADDRESS OF 3-WORD STRUCTURE
; BLOCK MOVE OPCODE < ADR1 < ADR2 < ADR3 < REGADR
; TO STACK
; CALL HALT PROCEDURE, EXPECTING PASCAL CONVENTIONS TO
; BE HONORED.
; THE BLOCK MOVE CAN BE DONE WITH A PAIR OF MOVEM'S SO LONG
; AS AN EXTRA WORD IS COPIED (TO HAVE A WHOLE NUMBER OF
; LONGS).
;-----------------------------------------------------------
HALT2OP:
LEA FINISH2,A4
HALTCOMMON:
MOVE.W D7,-(SP) ; push pending CCR
MOVE.W D0,-(SP) ; push halt exceptions
PEA (SP) ; ADDRESS OF CCR/D0
MOVEM.L LKRET+2(A6),D0-D3 ; PUSH ADDRESSES & OPCODE ON STACK
MOVEM.L D0-D3,-(SP)
ADDQ #2,SP ; adjust SP to point to opcode
MOVEA.L (A1),A1 ; CALL USER HALT HANDLER
JSR (A1)
MOVE.L (SP)+,D7 ; RESTORE CCR BITS AND STACK
JMP (A4)
;-----------------------------------------------------------
;-----------------------------------------------------------
FINI1OP:
MOVEA.W #FPSTATE,A1
CLR D7
MOVE.W (A1),D0 ; GET STATE WORD
CLR.B D6 ; KILL SIGNS
OR.W D6,D0
MOVE.W D0,(A1)+ ; BUMP ADRS TO VECTOR
ROR.W #8,D6 ; ALIGN BYTES
AND.W D6,D0
BNE.S HALT1OP ; ZERO IF NO TRAP
FINISH1:
MOVE D7,CCR
MOVEM.L (SP)+,D0-D7/A0-A4
UNLK A6
RTD #STKREM1
;-----------------------------------------------------------
;-----------------------------------------------------------
HALT1OP:
LEA FINISH1,A4
BRA.S HALTCOMMON
;-----------------------------------------------------------
; These routines handle the special cases in operations
; when the DST operand is the exact extended result.
; Subcase depends on whether the sign should also be stuffed.
; (The SRC-is-result case is always trivial).
;-----------------------------------------------------------
RDSTSGN:
ADD.B D6,D6 ; shift DST sign to bit 7
RDST:
MOVE.L A2,D5
MOVE.L D3,D4
MOVEA.L A3,A4 ; exponent, too
BRA PACKX ; coerce and pack result
Reference in New Issue Copy Permalink