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
2415ed21b7
mac-rom/Toolbox/SANE/ELEMS020_1.a

1246 lines
36 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: ELEMS020_1.a
;
; Copyright: <09> 1990-1991 by Apple Computer, Inc., all rights reserved.
;
; This file is used in these builds: Mac32
;
; Change History (most recent first):
;
; <6> 5/21/91 gbm Nail a couple of warnings
; <5> 9/15/90 BG Removed <4>. 040s are behaving more reliably now.
; <4> 7/17/90 BG Added EclipseNOPs for flakey 040s.
; <3> 4/14/90 JJ Make changes to support new binary-to-decimal, 96-bit precision,
; and improved Pack 5.
; <2> 3/2/90 JJ Changed value of SANETrapAddr to point directly to dispatch
; table.
; <1> 3/2/90 JJ First checked in.
;
; To Do:
;
;-----------------------------------------------------------
; File: ELEMS020_1.a
;-----------------------------------------------------------
;-----------------------------------------------------------
; 26 MAR 90 Modified to support 96-bit extended type (JPO).
;-----------------------------------------------------------
;-----------------------------------------------------------
; There are four logarithm functions: LN(x), LOG2(x), LN(1+x), and LOG2(1+x).
; They share much of the same code, but are distinguished by two bits.
; In the same way, EXP(x), EXP2(x), EXP(x)-1, EXP2(x)-1 share the same
; startup code.
;-----------------------------------------------------------
BLANKS ON
STRING ASIS
BTLOGBASE2 EQU 1 ; SET IF EITHER LOG2(X) OR LOG2(1+X)
; SET IF EITHER EXP2(X) OR EXP2(X)-1
BTLOG1PLUSX EQU 2 ; SET IF EITHER LN(1+X) OR LOG2(1+X)
; SET IF EITHER EXP(X)-1 OR EXP2(X)-1
;-----------------------------------------------------------
; When ELEMS68 is entered the stack has the form:
; ret adrs < opcode word < dst adrs < src adrs < src2 adrs
; with a second source address only in the case of the financial functions
; Compound and Annuity. A LINK is made through A6 (leaving A5 intact for
; the debugger people) and the following stack frame is set up:
;
; ......
; source2 address -- only if Compound or Annuity
; source address -- for Comp., Ann., X^I, X^Y
; destination address
; opcode word
; return address -- top of stack on entry to ELEMS68
; saved A6 -- for LINK, pntd to by A6 throughout ELEMS68
; environment word-- slot to save user's env across ELEMS68
; I -- word for integer temporary
; J -- word...
; W -- 5 words for extended temporary
; X -- 5 words...
; Y -- 5 words...
; Z -- 5 words...
; SRCCOPY -- 5 words for 80-bit copy of 96-bit SRC
; SRC2COPY -- 5 words for 80-bit copy of 96-bit SRC2
; saved D0-D7/A0-A4-- done with MOVEM.L after LINK
;
; After the operand addresses are fetched, the return address is written
; onto the deepest operand address, and the high word of the return address
; (the top of stack after the UNLK) is set to the number of bytes down to
; the relocated return address. To see how simple the subsequent exit
; procedure is, look at the code below label RESULTDELIVERED.
;
; The following constants index the stack frame off of A6:
;-----------------------------------------------------------
STSRC2 EQU 18 ; SOURCE2
STSRC EQU 14 ; SOURCE
STDST EQU 10 ; DESTINATION
STOPCODE EQU 8 ; OPCODE WORD
STRET EQU 4 ; RETURN ADDRESS
STA5 EQU 0 ; SAVED A6
STENV EQU -2 ; ENVIRONMENT SLOT
STI EQU -4 ; I
STJ EQU -6 ; J
STW EQU -16 ; W
STX EQU -26 ; X
STY EQU -36 ; Y
STZ EQU -46 ; Z
SCOPY EQU -56 ; SRC copy
S2COPY EQU -66 ; SRC2 copy
STLOCK EQU -68 ; HIGH WORD OF HANDLE
STFRAMESIZE EQU -68 ; SIZE OR FRAME FROM LINK
;-----------------------------------------------------------
; The following constants give the number of stack bytes to pop before exit.
;-----------------------------------------------------------
KI1ADRS EQU 6 ; OLD RET AND OPCODE
KI2ADRS EQU 10 ; OLD RET, OPCODE, DST
KI3ADRS EQU 14 ; OLD RET, OPCODE, DST, SRC
;-----------------------------------------------------------
; The opword is defined as:
; XY00 0000 Z0NN NNN0
; where X=1 for 2- or 3-address functions, Y=1 for 3-address functions,
; Z = 1 for 96-bit extended operands, and <NN NNN0> is the index
; into the jump table for the specific instruction.
;-----------------------------------------------------------
OP2ADRS EQU 15 ; SET IF 2-ADRS
OP3ADRS EQU 14 ; SET IF 3-ADRS
OPMASK EQU $003E ; MASK FOR JUMP TABLE INDEX
;-----------------------------------------------------------
; For scaling via FSCALBX, integer argument must be kept less than the
; maximum magnitude in a 16-bit integer. When outlandish scaling is
; required below, FSCALBX is called in units of MAXINT.
;-----------------------------------------------------------
MAXINT EQU 32767 ; 2^15 - 1
;-----------------------------------------------------------
; When raising extended to an integer power, do explicit multiplies when
; the exponent is smaller than some threshold. It's 255 for now.
; When the exponent exceeds this threshold, computation is done with
; log and exp.
;-----------------------------------------------------------
SMALLEXP EQU 255
;-----------------------------------------------------------
; The environment word is maintained at low memory addr FPSTATE.
;-----------------------------------------------------------
FPSTATE EQU $0A4A
;-----------------------------------------------------------
; The PACK4 (SANE FP) entry point is in low memory addr SANETrapAddr.
;-----------------------------------------------------------
SANETrapAddr EQU ToolTable+4*$1eb ; address of Pack4 in dispatch table
;-----------------------------------------------------------
; Here are the poor man's macros for getting at the arithmetic:
;-----------------------------------------------------------
MACRO
ELFADDX
MOVE #0,-(SP)
JSR (A3)
ENDM
MACRO
ELFSUBX
MOVE #2,-(SP)
JSR (A3)
ENDM
MACRO
ELFMULX
MOVE #4,-(SP)
JSR (A3)
ENDM
MACRO
ELFDIVX
MOVE #6,-(SP)
JSR (A3)
ENDM
MACRO
ELFCMPX
MOVE #8,-(SP)
JSR (A3)
ENDM
MACRO
ELFREMX
MOVE #$C,-(SP)
JSR (A3)
ENDM
MACRO
ELFI2X
BSR ELI2X
ENDM
MACRO
ELFX2X
MOVE #$0E,-(SP)
JSR (A3)
ENDM
MACRO
ELFX2I
MOVE #$2010,-(SP)
JSR (A3)
ENDM
MACRO
ELFRINTX
MOVE #$14,-(SP)
JSR (A3)
ENDM
MACRO
ELFSCALBX
MOVE #$18,-(SP)
JSR (A3)
ENDM
MACRO
ELFPROCEXIT
BSR ELPROCEXIT
ENDM
MACRO
ELFLOGBX
BSR ELLOGBX
ENDM
MACRO
ELFCLASSX
BSR ELCLASSX
ENDM
;-----------------------------------------------------------
;-----------------------------------------------------------
; ELEMS020---sole entry point to package
;-----------------------------------------------------------
;-----------------------------------------------------------
ELEMS020 PROC EXPORT
LINK A6,#STFRAMESIZE ; ALLOCATE TEMP CELLS
MOVEM.L D0-D7/A0-A4,-(SP) ; PRESERVE WORKING REGS
MOVEQ #0,D3 ; ERROR BITS AND OPCODE
;-----------------------------------------------------------
; Load the registers as follows:
; A3 <-- PACK4 (SANE FP) entry point stored
; in low memory global SANETrapAddr
; A4 <-- dst adrs
; D4 <-- src adrs, if any
; D5 <-- src2 adrs, if any, dst if there is none
; D3 <-- opcode word
; D2 <-- src class, if any
; D1 <-- dst/src2 class
;
; D6 <-- scratch
; D7 <-- scratch
;
; Nuisance: must avoid trying to classify the integer src to the X^I operation.
;
; Note: the assembly language class function FCLASSX returns a nonzero value
; with the sign of the input argument; the magnitude of the value is 1
; greater than the value of the Pascal enumerated type in the Elems interface.
;
; Note after the operand addresses are fetched the stack is set up for later
; exit, that is the return address is moved to the deepest available long
; word and the number of other bytes to kill is stored in the high word of
; the former return address. See the stack notes in the EQU section above
; and the exit sequence at label RESULTDELIVERED.
;-----------------------------------------------------------
MOVEA.L (SANETrapAddr).W,A3 ; A3 <- PACK4 entry point for duration
LEA STRET(A6),A2 ; POINT TO RET ADRS
LEA STOPCODE(A6),A0 ; POINT INTO STACK ARGS
MOVE.W (A0)+,D3 ; GET OPCODE
BPL DSTONLY ; QUICK TEST OF #OP2ADRS BIT
MOVEA.L (A0)+,A4 ; DST ADRS, ANOTHER ADRS COMING
MOVE.L (A0),D4 ; SRC TOO, BUT NO INCREMENT
BTST #OP3ADRS,D3
BNE.S HAVESRC2
;-----------------------------------------------------------
; Get here if have src and dst operands only.
;-----------------------------------------------------------
TST.B D3 ; 96-bit extended?
BPL.S @1 ; no. 80-bit
MOVE.W (A4),2(A4) ; yes. convert DST to 80-bit and bump pointer
ADDQ.L #2,A4
@1:
MOVE.L (A2),(A0) ; RET ADRS ON SRC ADRS
MOVE.W #KI2ADRS,(A2) ; STACK KILL COUNT
MOVE.L A4,D5 ; PRETEND THERE'S A SRC2
MOVEQ #15,D2 ; PRESET SRC CLASS IN CASE X^I
MOVEQ #OPMASK,D0 ; SPECIAL CASE WITH INTEGER OP
AND.W D3,D0
CMPI.B #$10,D0
BEQ.S CLASSDSTORSRC2
CLASSCOM:
TST.B D3 ; 96-bit extended?
BPL.S CLCOM2 ; no. 80-bit
CLCOM1:
MOVE.L D4,A0 ; yes. copy 96-bit SRC to 80-bit SRCCOPY
LEA SCOPY(A6),A1
MOVE.L A1,D4 ; D4 points to SRCCOPY
MOVE.W (A0),(A1)+
MOVE.L 4(A0),(A1)+
MOVE.L 8(A0),(A1)
CLCOM2:
MOVEA.L D4,A0 ; CLASSIFY SRC OPERAND
BSR.S CLASSIFY
MOVE.W D0,D2 ; SRC CLASS CODE
CLASSSKIP:
BRA.S CLASSDSTORSRC2
;-----------------------------------------------------------
; Get here if src, src2, and dst operands. Get src2 adrs and classify.
; Only Compound and Annuity have a src2.
;-----------------------------------------------------------
HAVESRC2:
ADDQ.L #4,A0 ; SKIP OVER SRC ADRS
MOVE.L (A0),D5 ; SRC2 addr
MOVE.L (A2),(A0) ; RET ADRS ON SRC ADRS
MOVE.W #KI3ADRS,(A2) ; STACK KILL COUNT
TST.B D3 ; 96-bit extended operands?
BPL.S CLCOM2 ; no. 80-bit extended
ADDQ #2,A4 ; yes. bump DST pointer for 80-bit interim result
MOVE.L D5,A0 ; copy 96-bit SRC2 to 80-bit SRC2COPY
LEA S2COPY(A6),A1
MOVE.L A1,D5
MOVE.W (A0),(A1)+
MOVE.L 4(A0),(A1)+
MOVE.L 8(A0),(A1)
BRA.S CLCOM1 ; copy 96-bit SRC to 80-bit SRCCOPY
;-----------------------------------------------------------
; Handy place to stick the following routine.
; Input: A0 = operand address
; Output: D0 = class code
; Uses: stack cell I to receive class
; D0.B has value 1-6 according to SNAN, QNAN, INF, ZERO, NORMAL, DENORMAL
; and the high bit D0.W (i.e. #$8000) is set according to the op's sign.
;-----------------------------------------------------------
CLASSIFY:
PEA (A0) ; EXTENDED SOURCE
PEA STI(A6) ; INTEGER DST FOR CLASS
ELFCLASSX ; RETURNS SIGNED 1-6
MOVE.W STI(A6),D0
BPL.S @1
NEG.W D0
ORI.W #$8000,D0 ; ISOLATE SIGN IN HIGH BIT
@1
RTS
;-----------------------------------------------------------
; Get here in usual case of unary operator.
;-----------------------------------------------------------
DSTONLY:
MOVEQ #15,D2 ; FAKE A NON-NAN CLASS CODE
MOVE.L (A0),A4 ; DST ADRS
TST.B D3 ; 96-bit extended?
BPL.S @1 ; no. 80-bit
MOVE.W (A4),2(A4) ; yes. convert to 80-bit and bump pointer
ADDQ.L #2,A4
@1:
MOVE.L (A2),(A0) ; RET ADRS
MOVE.W #KI1ADRS,(A2) ; KILL COUNT
MOVE.L A4,D5 ; PRETEND DST IS SRC2
CLASSDSTORSRC2:
MOVEA.L D5,A0 ; SRC2 OR DST ADRS
BSR.S CLASSIFY
MOVE.W D0,D1
;-----------------------------------------------------------
; Now save the user's environment and set all flags and halts off and rounding
; to nearest.
; Output: Environment cell.
; Uses: cell I to hold default environment
;-----------------------------------------------------------
MOVE.W (FPSTATE).W,STENV(A6) ; save environment in cell
CLR.W (FPSTATE).W ; set default environment
;-----------------------------------------------------------
; Check for NANs, either D1 (dst/src2) or D2 (src) equal to 1 or 2.
; If the src is a NAN, there might be two NANs so let floating add
; determine precedence, or propagate the one NAN. If just the dst
; (or possibly src2) is a NAN, do a simple move, in order to touch
; any signaling NAN that may have appeared.
;-----------------------------------------------------------
SUBQ.B #FCINF,D2 ; IS < 0 FOR SRC NANS
BGE.S NOT2NANS
MOVEA.L D5,A0 ; MIGHT BE DST OR SRC2
MOVEA.L A4,A1 ; ALWAYS DST ADRS
BSR.S A0TOA1 ; JUST BIT COPY
MOVE.L D4,-(SP) ; SRC ADRS
PEA (A4) ; ALWAYS DST ADRS
ELFADDX
BRA.S NANEXIT
NOT2NANS:
SUBQ.B #FCINF,D1 ; CHECK SRC2 OR DST
BGE.S NONANS
MOVE.L D5,-(SP) ; SRC2 OR DST ADRS
PEA (A4) ; DST ADRS
ELFX2X
NANEXIT:
BRA RESULTDELIVERED
NONANS:
;-----------------------------------------------------------
; Fall through to here in typical case of no NANs.
; Have dst address in A4, src address in D4, dst or src2 address in D5.
; D1 and D2 contain the dst/src2 and src class codes, decremented by
; #FCINF.
; Jump to specific routine based on opword in D3.W.
;-----------------------------------------------------------
LIFTOFF:
MOVE.W D3,D0
ANDI.W #OPMASK,D0
MOVE.W ELEMSTAB(D0),D0
JMP LIFTOFF(D0)
ELEMSTAB:
DC.W LOGTOP-LIFTOFF ; LNX
DC.W LOGTOP-LIFTOFF ; LOG2X
DC.W LOGTOP-LIFTOFF ; LN1X
DC.W LOGTOP-LIFTOFF ; LOG21X
DC.W EXPTOP-LIFTOFF ; EXPX
DC.W EXPTOP-LIFTOFF ; EXP2X
DC.W EXP1TOP-LIFTOFF ; EXPX - 1
DC.W EXP1TOP-LIFTOFF ; EXP2X - 1
DC.W XPWRITOP-LIFTOFF
DC.W XPWRYTOP-LIFTOFF
DC.W COMPOUNDTOP-LIFTOFF
DC.W ANNUITYTOP-LIFTOFF
DC.W SINTOP-LIFTOFF
DC.W COSTOP-LIFTOFF
DC.W TANTOP-LIFTOFF
DC.W ATANTOP-LIFTOFF
DC.W RANDTOP-LIFTOFF
;-----------------------------------------------------------
; Utility to copy an extended operand from (A0) to (A1), resetting
; A1 to point to the head. Turns out not to be useful to reset A0,
; since it is always thrown away.
;-----------------------------------------------------------
A0TOA1:
MOVE.L (A0)+,(A1)+
MOVE.L (A0)+,(A1)+
MOVE.W (A0),(A1)
SUBQ.L #8,A1
RTS
;-----------------------------------------------------------
; Utility to evaluate a polynomial using Horner's recurrence.
; Input: A0 pts to result field (preserved).
; A1 pts to coefficient table (advanced beyond table).
; A2 pts to function value (preserved).
; Uses: D0
; All operands are extended. The polynomial table consists of
; a leading word N, a positive integer giving the degree of the
; polynomial, and then (N+1) extended coefficients, starting with
; that of the leading term.
; RESULT <-- C0 initially.
; RESULT <-- (RESULT * X) + CJ for J = 1 to DEGREE
; Since A1 is advanced beyond the end of the given coefficient table,
; POLEVAL may be used successively with consecutive tables, after setting
; A1 just once.
;-----------------------------------------------------------
POLYEVAL:
MOVE.W (A1)+,D0 ; GET LOOP INDEX
MOVE.L (A1),(A0) ; transfer leading coefficient to
MOVE.L 4(A1),4(A0) ; result field
MOVE.W 8(A1),8(A0)
POLYLOOP:
PEA (A2)
PEA (A0)
ELFMULX ; ACCUM <-- ACCUM * X
ADDQ.L #8,A1 ; SKIP 10 BYTES TO NEXT
ADDQ.L #2,A1 ; ...COEFFICIENT
PEA (A1)
PEA (A0)
ELFADDX ; ACCUM <-- ACCUM + CJ
SUBQ.W #1,D0
BGT.S POLYLOOP
ADDQ.L #8,A1 ; SKIP BEYOND END OF TABLE
ADDQ.L #2,A1
RTS
;-----------------------------------------------------------
; Clear the exception flag.
; Uses: D0.
;-----------------------------------------------------------
CLEARUFLOW:
MOVEQ #FBUFLOW,D0
BRA.S CLEARX
CLEAROFLOW:
MOVEQ #FBOFLOW,D0
BRA.S CLEARX
CLEARINVALID:
MOVEQ #FBINVALID,D0
BRA.S CLEARX
CLEARINEXACT:
MOVEQ #FBINEXACT,D0
CLEARX:
BCLR D0,(FPSTATE).W ; exception bit in high byte
RTS
;-----------------------------------------------------------
; Utility to force an exception flag. No halts are enabled in
; environment due to PROCENTRY, so simply turn on appropriate
; exception bit in environment global.
; Uses: D0.
;-----------------------------------------------------------
FORCEOFLOW:
MOVEQ #FBOFLOW,D0
BRA.S FORCEX
FORCEUFLOW:
MOVEQ #FBUFLOW,D0
BRA.S FORCEX
FORCEDIVZER:
MOVEQ #FBDIVZER,D0
BRA.S FORCEX
FORCEINVALID:
MOVEQ #FBINVALID,D0
BRA.S FORCEX
FORCEINEXACT:
MOVEQ #FBINEXACT,D0
FORCEX:
BSET D0,(FPSTATE).W ; exception bit in high byte
RTS
;-----------------------------------------------------------
; Utility to test an exception flag.
; Output: Z flag in CCR is true if flag is off, Z is false if flag is set.
;-----------------------------------------------------------
TESTDIVZER:
MOVEQ #FBDIVZER,D0
BRA.S TESTX
TESTUFLOW:
MOVEQ #FBUFLOW,D0
BRA.S TESTX
TESTOFLOW:
MOVEQ #FBOFLOW,D0
BRA.S TESTX
TESTINVALID:
MOVEQ #FBINVALID,D0
BRA.S TESTX
TESTINEXACT:
MOVEQ #FBINEXACT,D0
TESTX: ; test exception bit in high byte
BTST D0,(FPSTATE).W ; of environment word
RTS
;-----------------------------------------------------------
; Floating scalb function computes (A0) <-- (A0) * 2^(A1)
; Because of the 15-bit exponent range, just two invocations
; of FSCALBX are required if an over/underflow is to be stimulated.
; A0, A1, and (A1) are not modified.
; Uses: cells J and Y, A2
;-----------------------------------------------------------
SCALBXX:
MOVE.W #MAXINT,STJ(A6) ; SEEDED INTEGER SLOT
LEA STY+10(A6),A2 ; BEYOND CELL Y
MOVE.L 6(A1),-(A2) ; COPY OF (A1)
MOVE.L 2(A1),-(A2)
MOVE.W (A1),-(A2)
BCLR #7,(A2) ; ABS (A1) COPY
;-----------------------------------------------------------
; If ABS(A1) is larger than MAXINT then do one step of scaling by MAXINT.
;-----------------------------------------------------------
BSR.S VSMAXINT
FBGES At1 ; FLOATING >=
;-----------------------------------------------------------
; Must diminish (A2) by FPKMAXINT.
;-----------------------------------------------------------
PEA FPKMAXINT
PEA (A2)
ELFSUBX
TST.B (A1) ; CHECK OPERAND SIGN
BPL.S @1
NEG.W STJ(A6) ; -MAXINT IN INTEGER CELL
@1:
BSR.S SCALEINT ; SCALE BY STJ(A6)
;-----------------------------------------------------------
; If (SP) exceeds FPKMAXINT at this step, just force signed FPMAXINT.
;-----------------------------------------------------------
BSR.S VSMAXINT ; (A2) VS FPMAXINT
FBGES At1 ; FLOATING >=
PEA FPKMAXINT
BRA.S At3
At1:
PEA (A2) ; USE REDUCED VALUE
At3:
PEA STJ(A6) ; ADDRESS OF INT SLOT
ELFX2I
TST.B (A1)
BPL.S @5
NEG.W STJ(A6) ; FORCE SIGN OF INTEGER
@5:
;-----------------------------------------------------------
; FALL THROUGH AND EXIT
;
; Scale (A0) by integer at STJ(A6).
;-----------------------------------------------------------
SCALEINT:
PEA STJ(A6)
PEA (A0)
ELFSCALBX
RTS
;-----------------------------------------------------------
; Compare STY(A6) with FPMAXINT.
;-----------------------------------------------------------
VSMAXINT:
PEA STY(A6)
PEA FPKMAXINT
ELFCMPX
RTS
;-----------------------------------------------------------
; ELLOGBX---fast LOGB routine expects finite, nonzero extended
; input, and so is nonexceptional. Interface is the same as
; that of the SANE ROM routine except for the absence of
; OPWORD on stack. Upon entry,
; STACK: &ret < &DST (input extended addr).
; Upon exit, integral exponent value is written in extended
; format to DST addr and stack is popped.
;-----------------------------------------------------------
ELLOGBX:
MOVEM.L A0/D0-D2,-(SP) ; save small # of registers
MOVEQ #0,D1 ; zero D1
MOVEA.L 20(SP),A0 ; A0 <- &DST
MOVE.W (A0),D1 ; D1.W <- sign/exp
BCLR #15,D1 ; sign of operand irrelevant
MOVE.L 2(A0),D0 ; sig.HI into D0
BMI.S @3 ; already normalized
BFFFO D0{0:0},D2 ; find first set bit in sig.HI
BNE.S @1 ; sig.HI is nonzero
SUB.W D2,D1 ; adjust exp (D2 must contain 32)
MOVE.L 6(A0),D0 ; D0 <- sig.LO (must be nonzero)
BFFFO D0{0:0},D2 ; find first set bit in sig.LO
@1:
SUB.W D2,D1 ; adjust exp to normalized value
@3:
MOVE.W #$401E,D0 ; tentative exp for LOGB
SUB.W #$3FFF,D1 ; unbias exp of input
BGT.S @7 ; result > 0
BLT.S @5 ; result < 0
MOVE.L D1,D0 ; zero result
BRA.S @9 ; deliver it
@5:
BSET #15,D0 ; negative result; set sign bit
NEG.W D1 ; negate integer
@7:
BFFFO D1{0:0},D2 ; find first one to normalize
LSL.L D2,D1 ; shift left
SUB.W D2,D0 ; adjust result exponent
@9:
MOVE.W D0,(A0)+ ; deliver exp of result
MOVE.L D1,(A0)+ ; deliver sig.HI
CLR.L (A0) ; sig.LO is zero
MOVEM.L (SP)+,A0/D0-D2 ; restore registers
RTD #4 ; return
;-----------------------------------------------------------
; ELCLASSX---fast CLASSX routine simulates the SANE ROM
; routine except for absence of OPWORD on stack. Upon entry,
; STACK: &ret < &DST < &SRC.
; Upon exit, classify code (integer) is written to &DST and
; stack is popped.
;-----------------------------------------------------------
ELCLASSX:
MOVEM.L A0/D0-D1,-(SP) ; save small # of registers
MOVEA.L 20(SP),A0 ; SRC addr
MOVE.W (A0)+,D0 ; get sign/exp in D0.W
ADD.L D0,D0 ; sign in D0 bit 16
LSR.W #1,D0 ; positive exp in D0.W
CMPI.W #$7FFF,D0 ; max exp?
BEQ.S @5 ; yes, NAN or INF class
MOVE.L (A0)+,D1 ; normalized?
BPL.S @8 ; zero or unnormalized
@2:
MOVEQ #5,D1 ; NORMAL
@3:
BTST #16,D0 ; negate class code if
BEQ.S @4 ; sign bit is set
NEG.W D1
@4:
MOVEA.L 16(SP),A0 ; DST addr
MOVE.W D1,(A0) ; deliver classify result
MOVEM.L (SP)+,A0/D0-D1 ; restore registers
RTD #8 ; done
@5: ; INF or NAN class
MOVE.L (A0)+,D1 ; read high half of significand
ADD.L D1,D1 ; clr explicit bit of sig
LSR.L #1,D1
BEQ.S @7 ; INF or SNAN class since sig high is zero
BTST #30,D1 ; QNAN or SNAN
BEQ.S @6 ;
MOVEQ #2,D1 ; QNAN
BRA.S @3
@6:
MOVEQ #1,D1 ; SNAN
BRA.S @3
@7:
MOVE.L (A0),D1 ; INF or SNAN?
BNE.S @6 ; SNAN
MOVEQ #3,D1 ; INF
BRA.S @3
@8:
BEQ.S @11 ; ZERO or SUBNORM
@9:
SUBQ.W #1,D0 ; normalization loop
ADD.L D1,D1
BPL.S @9
@10:
TST.W D0 ; negative exponent means SUBNORM
BPL.S @2 ; nonnegative means NORMAL
MOVEQ #6,D1 ; SUBNORM
BRA.S @3
@11: ; high significand is zero
SUB.W #32,D0 ; decrease exponent
MOVE.L (A0),D1 ; D1 <- low significand
BEQ.S @12 ; ZERO
BPL.S @9 ; still unnormalized
BRA.S @10 ; check exponent
@12:
MOVEQ #4,D1 ; ZERO
BRA.S @3
;-----------------------------------------------------------
; ELI2X---Fast INT2X conversion routine uses SANE ROM interface
; except for absence of OPWORD on stack. Upon entry:
; STACK: &ret < &DST < &SRC, where &SRC contains a 16-bit
; integer value and &DST will store the 80-bit
; extended result of the conversion.
; Upon exit, the stack is popped.
;-----------------------------------------------------------
ELI2X:
MOVEM.L A0/D0-D1,-(SP) ; save 3 registers
MOVEA.L 20(SP),A0 ; A0 <- SRC addr
MOVE.W #$400E,D0 ; set exponent for integer in D0.HI
SWAP D0
MOVE.W (A0),D0 ; SRC integer into D0.LO
BEQ.S @5 ; zero
BPL.S @1 ; positive; normalize
BSET #31,D0 ; negative; set sign bit
NEG.W D0 ; negate D0.L0
BMI.S @3 ; already normalized
@1:
SWAP D0 ; swap exp and first 16 sig bits
BFFFO D0{0:16},D1 ; find first one bit in sig
SUB.W D1,D0 ; adjust exponent
SWAP D0 ; swap exp and sig bits back
LSL.W D1,D0 ; shift significand to normalize
@3:
MOVEA.L 16(SP),A0 ; DST addr
MOVE.L D0,(A0)+ ; write extended result
CLR.L (A0)+ ; with trailing zeros
CLR.W (A0)
MOVEM.L (SP)+,A0/D0-D1 ; pop registers
RTD #8 ; return
@5:
MOVEQ #0,D0 ; zero result
BRA.S @3 ; output it
;-----------------------------------------------------------
; ELPROCEXIT---Fast PROCEXIT routine uses SANE ROM interface
; except for absence of OPWORD on stack. Upon entry:
; STACK: &ret < &DST, where &DST contains an environment
; word to be restored.
; Upon exit, the current exceptions are ORed into the environment
; at &DST, the result becomes the new environment, a halt is
; taken if any of the current exceptions were halt-enabled in
; the restored environment, and the stack is popped.
;-----------------------------------------------------------
ELPROCEXIT:
MOVEM.L D0/D6/A0,-(SP) ; Use 3 registers
MOVEA.L 16(SP),A0 ; old environment addr
MOVE.W #$0019,D6 ; opword into D6.HI
SWAP D6
MOVE.W #$1F00,D6 ; exception mask in D6.W
AND.W (FPSTATE).W,D6 ; current exceptions in D6.W
MOVE.W (A0),D0 ; old environment into D0.W for restoration
FASTFIN:
OR.W D6,D0 ; OR new exceptions with old environment
MOVE.W D0,($0A4A).W ; store resulting environment
LSR.W #8,D6 ; check for halt
AND.W D6,D0
BNE.S FASTHALT ; handle halt
FASTEX:
MOVE D0,CCR ; zero CCR
MOVEM.L (SP)+,D0/D6/A0 ; restore registers
RTD #4 ; done
;-----------------------------------------------------------
; Fast halt vectoring routine for PROCEXIT
;-----------------------------------------------------------
FASTHALT:
LEA 16(SP),A0 ; A0 points to DST addr on stack
CLR.W -(SP) ; push CCR = 0 below D0 save
MOVE.W D0,-(SP) ; push HALT exceptions
PEA (SP) ; push MISCHALTINFO record pointer
MOVE.L 8(A0),-(SP) ; push bogus SRC2 addr
MOVE.L 4(A0),-(SP) ; push bogus SRC addr
MOVE.L (A0),-(SP) ; push DST addr
SWAP D6 ; push opword
MOVE.W D6,-(SP)
MOVEA.L ($0A4C).W,A0 ; call user halt handler
JSR (A0)
MOVE.L (SP)+,D0 ; pop HALT exception/CCR off stack
BRA.S FASTEX ; exit
;-----------------------------------------------------------
;-----------------------------------------------------------
; Logarithm functions.
; All four functions LN(x), LOG2(x), LN(1+x), and LOG2(1+x)
; are launched by common error-checking code. In the usual case
; that arithmetic is required, the computation is cast in the form
; log2(1+z). The only difference between LN and LOG2 is that the
; former requires a final multiplication by LN(2).
;
; The four functions are distinguished by the BTLOGBASE2 and
; BDLOG1PLUSX bits as described in the EQUATES section above.
;
; Since the only operand is the destination, the relevant class code
; (already diminished by FCINF in the NAN check) is in D1.
;-----------------------------------------------------------
;-----------------------------------------------------------
LOGTOP:
SUBQ.B #1,D1
BPL.S LOGFINITE ; -1 FOR INF, NONNEG FOR FINITE
TST.W D1 ; CHECK SIGN BIT
BPL PINFSTUFF ; LOG(+INF) IS +INF
LOGERROR:
MOVEQ #NANLOG,D0 ; ERROR CODE
BRA ERRORNAN ; LOG(-INF) IS AN ERROR
LOGFINITE:
BTST #BTLOG1PLUSX,D3
BNE.S LOG1PLUSX
TST.B D1 ; 0 IF OPERAND IS 0
BEQ.S LOG0 ; -INF, WITH DIVIDE BY 0
TST.W D1 ; CHECK SIGN
BMI.S LOGERROR
BRA.S LOG2R ; COMPUTE LOG(X)
LOG1PLUSX:
TST.B D1
BEQ RESULTDELIVERED ; LOG(+-0) IS +-0
PEA (A4)
PEA FPKM1
ELFCMPX
FBUGTS LOGERROR ; -1 > OPERAND --> ERROR
FBLTS LOG12R ; FIND LOG(1+X)
; FALL THROUGH WHEN = -1
LOG0:
BRA DIVM0STUFF
;-----------------------------------------------------------
; END OF SPECIAL CASES
;-----------------------------------------------------------
;-----------------------------------------------------------
; Compute LOG2(1+T) for some positive, finite T.
; If 1+T falls outside the range SQRT(1/2) to SQRT(2) then
; just go to the code for LOG2(S) below. Else use LOGAPPROX
; on T itself, IGNORING the sum 1+T.
;-----------------------------------------------------------
LOG12R:
;-----------------------------------------------------------
; First compute 1+T, saving the input T in cell W.
;-----------------------------------------------------------
MOVEA.L A4,A0 ; INPUT PTR
LEA STW(A6),A1 ; PTR TO W CELL
BSR A0TOA1 ; COPY OF INPUT IN W
PEA FPK1
PEA (A4)
ELFADDX ; W <-- 1+T
;-----------------------------------------------------------
; Now compare with bounds SQRT(1/2) and SQRT(2).
;-----------------------------------------------------------
PEA FPKSQRTHALF
PEA (A4)
ELFCMPX
FBULES LOG2R
PEA (A4)
PEA FPKSQRT2
ELFCMPX
FBLES LOG2R
;-----------------------------------------------------------
; Input T is within the required range so restore input value and
; just LOGAPPROX and finish up.
;-----------------------------------------------------------
MOVEA.L A1,A0 ; STW(A6) LEFT FROM BEFORE
MOVEA.L A4,A1
BSR A0TOA1
BSR.S LOGAPPROX
BRA.S LOGFINI
;-----------------------------------------------------------
; Compute LOG2(T) for some positive, finite T.
; Represent T as 2^L * Q for SQRT(1/2) <= Q <= SQRT(2).
; Then LOG2(T) is L + LOG2(Q).
; LOG2(Q) for that restricted range is computed at LOGAPPROX below.
;-----------------------------------------------------------
LOG2R:
;-----------------------------------------------------------
; Compute LOGB(T), i.e. L, in W.
;-----------------------------------------------------------
MOVEA.L A4,A0
LEA STW(A6),A1
BSR A0TOA1 ; COPY X TO W
PEA (A1)
ELFLOGBX
;-----------------------------------------------------------
; Then scale T down to range 1 to 2. A single scaling step suffices
; since the logb result ranges between -16446 and +16383
;-----------------------------------------------------------
BCHG #7,(A1) ; -L IN W
PEA (A1) ; CONVERT LOGB RESULT TO INTEGER
PEA STJ(A6) ; USE CELL J
ELFX2I
PEA STJ(A6)
PEA (A4)
ELFSCALBX ; (A4) <-- (A4) * 2^(A1)
BCHG #7,(A1) ; BACK TO L IN W
;-----------------------------------------------------------
; If scaled value exceeds SQRT(2), then halve T and increment L.
;-----------------------------------------------------------
PEA FPKSQRT2
PEA (A4)
ELFCMPX
FBULES At11
PEA FPK1
PEA STW(A6)
ELFADDX ; INCREMENT L
SUB.W #1,(A4) ; HALVE T BY DECREMENTING ITS EXPONENT
At11:
;-----------------------------------------------------------
; Now must subtract 1 from (A4) in order to use LOGAPPROX,
; which approximates LOG2(1+S).
;-----------------------------------------------------------
PEA FPK1
PEA (A4)
ELFSUBX
BSR.S LOGAPPROX
;-----------------------------------------------------------
; Add L in. Exit via check to see whether to multiply by LN(2).
;-----------------------------------------------------------
PEA STW(A6)
PEA (A4)
ELFADDX
;-----------------------------------------------------------
; Finish up with a multiply by LN(2) if a natural log was requested.
;-----------------------------------------------------------
LOGFINI:
BTST #BTLOGBASE2,D3
BNE.S @1
PEA FPKLOGE2
PEA (A4)
ELFMULX ; LOG2(X) * LN(2)
@1:
BRA RESULTDELIVERED
;-----------------------------------------------------------
; Compute LOG2(1+S) for S between SQRT(1/2) and SQRT(2).
; Assume all special cases have been filtered out and that
; number (A4) is indeed within range.
; Let R := S / (2 + S).
; Then LOGAPPROX := R * P(R*R) / Q(R*R),
; where the coefficients are taken from LOG21P and LOG21Q.
;
; Leave cell W alone, for use by LOG2R.
; Use cell Y for R, X for R*R.
; Use (A4) for R * P(R*R); then Y for Q(R*R).
; Registers A0-A2 are used by the POLYEVAL.
;
; To avoid spurious inexact, filter out 0.
; To keep accuracy, filter out denorms.
;-----------------------------------------------------------
LOGAPPROX:
PEA (A4) ; INPUT OPERAND X
PEA STJ(A6) ; CELL J FOR CLASS
ELFCLASSX ; LEAVES -6, ..., 6 IN CELL J
MOVE.W STJ(A6),D0
BPL.S @1
NEG.W D0
@1
SUBQ.W #FCZERO,D0 ; QUICK EXIT IF ZERO, #FCZERO=4
BNE.S LANONZERO
RTS
LANONZERO:
SUBQ.W #1,D0 ; #FCNORM=5, #FCDENORM=6
BEQ.S LANORMAL
;-----------------------------------------------------------
; Since log2(1 + tiny) = ln(1 + tiny) / ln(2) and ln(1 + tiny) is tiny + ...
; just divide denorm by ln(2) and return. Share exit code with main computation.
;-----------------------------------------------------------
PEA FPKLOGE2
BSR FORCEUFLOW
BRA.S LAFINI
LANORMAL:
MOVEA.L A4,A0
LEA STX(A6),A1
BSR A0TOA1 ; COPY ARGUMENT TO X
PEA FPK2
PEA (A4)
ELFADDX ; S := S + 2
PEA (A4)
PEA (A1) ; ADRS OF CELL X
ELFDIVX ; X := S / S + 2
MOVEA.L A1,A0 ; ADRS OF CELL X
PEA (A1) ; TWO COPIES FOR SQUARE
PEA (A1)
LEA STY(A6),A1 ; ADRS OF CELL Y
BSR A0TOA1 ; Y := R
ELFMULX ; X := R * R
;-----------------------------------------------------------
; Evaluate P(R*R) into (A4).
;-----------------------------------------------------------
MOVEA.L A4,A0 ; RESULT SLOT
LEA LOG21P,A1 ; COEFFICIENTS OF P
LEA STX(A6),A2 ; R*R
BSR POLYEVAL ; P(R*R)
;-----------------------------------------------------------
; Evaluate R * P(R*R) into (A4); then finished with R in Y.
;-----------------------------------------------------------
PEA STY(A6) ; R
PEA (A4) ; P(R*R)
ELFMULX ; R * P(R*R)
;-----------------------------------------------------------
; Evaluate Q(R*R) into cell Y.
;-----------------------------------------------------------
LEA STY(A6),A0 ; RESULT SLOT
LEA LOG21Q,A1 ; COEFFICIENTS OF Q
LEA STX(A6),A2 ; R*R
BSR POLYEVAL ; Q(R*R)
;-----------------------------------------------------------
; Be sure inexact is set (isn't it set in the course of things?) and clear
; all underflows up to the last step.
; Finally, divide (R* P(R*R)) in (A4) by Q(R*R) in cell Y.
;-----------------------------------------------------------
BSR CLEARUFLOW
PEA STY(A6)
LAFINI:
PEA (A4)
ELFDIVX ; (R * P(R*R)) / Q(R*R)
BSR FORCEINEXACT
RTS ; EXIT LOGAPPROX
;-----------------------------------------------------------
; Trailing stubs to deal with special values to be delivered.
; It is less efficient to use a BSR.S at every label and compute the
; value's address from the return address on the stack.
;-----------------------------------------------------------
P0STUFF:
LEA FPK0,A0
BRA.S STUFFVAL
M0STUFF:
LEA FPKM0,A0
BRA.S STUFFVAL
P1STUFF:
LEA FPK1,A0
BRA.S STUFFVAL
M1STUFF:
LEA FPKM1,A0
BRA.S STUFFVAL
DIVP0STUFF:
BSR FORCEDIVZER
PINFSTUFF:
LEA FPKINF,A0
BRA.S STUFFVAL
DIVM0STUFF:
BSR FORCEDIVZER
MINFSTUFF:
LEA FPKMINF,A0 ; AND FALL THROUGH...
STUFFVAL:
MOVEA.L A4,A1 ; DST ADRS
BSR A0TOA1 ; STUFF THE VAL
STUFFEXIT:
BRA.S RESULTDELIVERED
;-----------------------------------------------------------
; Fabricate a silent NAN, set Invalid, and deliver to destination.
; D0.B should be a nonzero byte code.
;-----------------------------------------------------------
ERRORNAN:
ORI.L #$7FFF4000,D0 ; MAX EXP AND QNANBIT SET! <01APR85>
MOVE.L D0,(A4)+
CLR.L (A4)+
CLR.W (A4)
SUBQ.L #8,A4
BSR FORCEINVALID
;-----------------------------------------------------------
; FALL THROUGH TO...
;-----------------------------------------------------------
;-----------------------------------------------------------
; Finally, a result has been placed in (A4). Restore the environment,
; signaling any required exceptions, restore the registers,
; clean up the stack, and go. The return address has been written onto the
; deepest operand address, and the high word of the old return address is
; an integer count of the amount of stack to kill to get to the true return
; address.
;-----------------------------------------------------------
RESULTDELIVERED:
;-----------------------------------------------------------
; The first step is to expand the 80-bit result to 96 bits if
; the operation is for the latter format. In this case, A4
; contains &DST + 2, and the sign/exponent must simply be
; copied from (A4) to -2(A4).
;-----------------------------------------------------------
TST.B D3 ; 96-bit result required?
BPL.S @1 ; no. 80-bit OK
MOVE.W (A4),-2(A4) ; yes. copy sign/exp to lead word
;-----------------------------------------------------------
; Restore from environment word
;-----------------------------------------------------------
@1:
PEA STENV(A6)
ELFPROCEXIT
;-----------------------------------------------------------
; Clean up the regs and exit.
;-----------------------------------------------------------
MOVEM.L (SP)+,D0-D7/A0-A4 ; RESTORE ALL REGS
UNLK A6
ADDA.W (SP),SP
RTS
Reference in New Issue Copy Permalink