Macintosh-SW/sys7.1-doc-wip
1
0
Fork 0
mirror of https://github.com/elliotnunn/sys7.1-doc-wip.git synced 2024-06-01 04:41:39 +00:00
Code Issues Projects Releases Wiki Activity
master
sys7.1-doc-wip/Toolbox/SANE/ELEMS020_1.a
Horst Beepmanh 33cd9271f4 SuperMarioProj.1994-02-09
2019-07-27 22:37:48 +08:00

1246 lines
36 KiB
Plaintext
Raw Permalink Blame History

;
; File: ELEMS020_1.a
;
; Copyright: © 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 View Git Blame Copy Permalink