4,887,235
393 394
funcall-funny-function-trap)
(increment-stack-pointer)
(function-entry-instruction-fetch (amem (xbas 1))))
;Point frame-pointer at first argument slot in new frame
(parallel (assign frame-pointer (1+ stack-pointer))
(assign a-pclsr-top-of-stack (set-type (1+ stack-pointer) dtp-null))
(keep-function-history call))
;Dispatch on entry instruction, maybe do seome work for callee
(dispatch-after-next (entry-instruction-dispatch memory-data)
((0) (next-instruction)) ;Callee will do it himself
;here callee does not want a rest argument. So this is either too
;many arguments, or need to call a support routine to pop some
;arguments off the list, which is known not to be NIL.
;Put in b-temp the maximum number of spread arguments the callee wants.
((1) (lexpr-funcall-fast 0))
((2 3) (lexpr-funcall-fast 1))
((4 5 6) (lexpr-funcall-fast 2))
((7 10 11 12) (lexpr-funcall-fast 3))
((13 14 15 16 17) (lexpr-funcall-fast 4)))
;Check for space in stack buffer
(parallel (trap-if (greater-pointer stack-pointer stack-limit)
(take-jump-trap stack-buffer-overflow-handler preserve-stack))
(take-dispatch)))
F:>lmach>ucode>FLOAT.LISP.33
;;; -*- Mode:Lisp; Package:Micro: Base:8; Lowercase:yes -*-
;;; (c) Copyright 1982, Symbolics, Inc.
;;;; Flonum microcode for 3600
;;; Denormalized number representation:
(define-enumerated-value-constants *flonum-operations*)
;;; Structure of "singles" flonums
;;; |1|--8---|-----23------|
;;; |S| expt | frac |
;;; 31<30:23>---<22:0>----
(defsysbyte single-frac 23. 0)
(defsysbyte single-N-bit 1 23.)
(defsysbyte single-expt 8. 23.)
(defsysbyte single-sign 1 31.)
(defsysbyte single-except-sign 31. 0)
(eval-when (eval compile load)
(defconst single-expt-max (field-mask single-expt))
(defconst single-expt-bias 127.)
(defconst single-expt-bias-adjust 192.)
);eval-when eval compile load
;;; Structure of internal significand ("frac")
;;; ... -----23---- --3--
;;; ... V N . xxxxxxxxxxL G R S
;;; ...2726 --<25:3>--- 2 1 0
;;; Where V is overflow bit, N is normalized bit, L is least-significant
;;; bit of the significand, C is guard bit, R is rounding bit, and
;;; S is sticky right-shift bit.
(defsysbyte frac-S-bit 1 0)
(defsysbyte frac-grs 3 0)
(defsysbyte frac-round-dispatch 4 0) ;LGRS
(defsysbyte frac-L-bit 1 3)
(defsysbyte frac-field 23. 3)
(defsysbyte frac-field-denormalized 23. 4) ;an extra bit over, since it has no N bit
(defsysbyte frac-normalize-dispatch 4 23.) ;highest bit is N
(defsysbyte frac-N-bit 1 26.)
(defsysbyte frac-V-bit 1 27.)
;;; Some common constants, abbreviated here.
(defmacro define-side-constants (side &rest list)
`(progn 'compile
,@(loop for n in list
collect `(defatomicro ,(fintern "~d@~a" n side)
(,(fintern "~a-CONSTANT" side) ,n)))))
(define-side-constants a 0 1 -1)
(define-side-constants b 1 2 30. 31. -1)
4,887,235
395 396
;;;; flonum-operating-mode
(defsysbyte rounding-mode 2 1)
(def-byte-field rounding-mode-with-inexact (3 1) rounding-mode-mumble)
;;inexact-result must be to immediate left of rounding mode. See single-round-z.
(eval-when (eval compile load)
(defmacro def-rounding-mode-names (&rest pairs)
(let* ((rm-names (loop for (name doc) in pairs
collect (fintern "ROUNDING-MODE-~a" name)))
(rm-with-inexact (append rm-names
(loop for name in rm-names
collect (fintern "~a-INEXACT" name)))))
`(progn 'compile
(defenumerated *rounding-mode-names* ,rm-names)
(defenumerated *rounding-mode-names-with-inexact* ,rm-with-inexact)
(defconst *flonum-rounding-mode-doc-alist*
',(loop for (() doc) in pairs
for name in rm-names
collect `(,doc . ,name))))))
(def-rounding-mode-names
(nearest "Nearest")
(zero "toward zero")
(plus "plus infinity")
(minus "minus infinity")
)
(associate-dispatch-cues rounding-mode *rounding-mode-names*)
(associate-dispatch-cues rounding-mode-with-inexact *rounding-mode-names-with-inexact*)
(define-enumerated-value-constants *rounding-mode-names*)
(define-enumerated-value-constants *rounding-mode-names-with-inexact*)
(defconst *flonum-trap-names*
'((inexact-result "Inexact Result")
(invalid-operation "Invalid Operation")
(overflow "Overflow")
(underflow "Underfiow")
(division-by-zero "Division by zero")))
(defmacro def-several-bytes (prefix collection start names)
`(progn compile
,@(loop for name in names
for index = start then (1+ index)
collect `(defsysbyte ,(fintern "~a-~a" prefix name) 1 ,index))
,@(and collection
`((defsysbyte ,collection ,(length names) ,start)))))
(def-several-bytes trap-enable trap-enables 3
(inexact-result invalid-operation overflow underflow division-by-zero))
(def-several-bytes flag flag-bits 8.
(inexact-result invalid-operation overflow underflow division-by-zero))
(def-several-bytes signal () 13.
(inexact-result invalid-operation overflow underflow division-by-zero))
(def-byte-field infinity-mode (1 18.) infinity-mode-mumble)
(defenumerated *infinity-mode-names* (infinity-mode-affine infinity-mode-projective))
(associate-dispatch-cues infinity-mode *infinity-mode-names*)
(defconst *infinity-mode-doc-alist*
`(("Affine" . infinity-mode-affine)
("Projective" . infinity-mode-projective)))
;;;These forms, e.g. (flag-invalid-operation), all take 2 cycles, but they
;;;get called only in exceptional cases anyway.
#.`(progn 'compile
,@(loop for condition in '("INVALID-OPERATION" "OVERFLOW" "UNDERFLOW" "DIVISION-BY-ZERO")
as flag-name = (fintern "FLAG-~a" condition)
collect `(defmicro ,flag-name ()
`(parallel
(assign b-temp (dpb-field lea ,',flag-name 0))
(call flag-flonum-operating-mode)))
as signal-name = (fintern "SIGNAL-~a" condition)
collect `(defmicro ,signal-name ()
`(parallel
(assign b-temp (dpb-field lea ,',signal-name 0))
(call flag-flonum-operating-mode)))))
;;This uses a b-side constant because it gets called all the bloody time, and wants
;;not to take 2 cycles.
(defmicro flag-inexact-result ()
`(assign flonum-operating-mode
(logior flonum-operating-mode (b-constant (field-mask flag-inexact-result)))))
(defmicro signal-inexact-result ()
`(assign flonum-operating-mode
(logior flonum-operating-mode (b-constant (field-mask signal-inexact-result)))))
4,887,235
397 398
(defmicro flag-inexact-result-and-return ()
`(parallel
(flag-inexact-result)
(return)))
(defmicro signal-inexact-result-and-trap ()
`(flonum-trap-to-macrocode (signal-inexact-result) fadd-operation))
;;;; Some general utility micros
;;This should be `(parallel (assign ,loc ,val) (if (fixnum-zero obus) ,@clauses))
;;Except that fixnuo-zero uses an alu operation.
;;Of course, we have to do it this way anyway since we can't check alu output for
;:zeroness, just for -1ness.
(defmicro if-zero-fixnum-assignment (pair &body clauses)
(if (not (= (length pair) 2))
(ferror () "Bad (loc val) pair in ~s"
`(if-zero-fixnum-assignment ,pair ,@clauses)))
(let ((loc (first pair)) (val (second pair)))
`(sequential
(assign ,loc ,val)
(if (zero-fixnum ,loc)
,@clauses))))
(defmicro if-minus-fixnum-assignment (pair &body clauses)
(if (not (= (length pair) 2))
(ferror () "Bad (loc val) pair in ~s"
`(if-zero-fixnum-assignment ,pair ,@clauses)))
(let ((loc (first pair)) (val (second pair)))
`(parallel
(assign ,loc ,val)
(if (minus-fixnum obus)
,@clauses))))
(defmicro ldb-regs (operand)
`(ldb ,operand byte-s byte-r))
(defmicro flonum-trap-to-macrocode (set-condition operation)
`(sequential
,set-condition
(parallel
(pushval (set-type ,operation dtp-fix))
(jump push-z-and-trap-to-macrocode))))
;;; Some temporaries.
(reserve-scratchpad-memory 2413 2420)
(define-b-temps leave-space-for-division-1
leave-space-for-division-2
x-expt ;wants to be en B side because of (ldb-field next-on-stack)
x-frac ;wants to be on B side because of (dpb-field next-on-stack)
y-sign ;wants to be opposite next-on-stack.
z-frac) ;on B because it gets replaced by byte operations on itself.
(defareg y-expt) ;wants to be on A side because of (ldb-field top-of-stack),
;also must be on different side from x-expt.
(defareg y-frac) ;wants to be on A side because of (dpb-field top-of-stack),
;also must be on different side from x-frac.
(defareg z-sign) ;not importantly, see pack-and-return-z
(defareg z-expt) ;probably on A because of hair in pack-and-return-z
(defareg expt-diff)
;;;; Some FADD micros
(defmicro fadd-adjust-y () ;7 cycles
`(sequential
(assign z-expt x-expt)
;XXXbrad 0@a?
(assign byte-r 0@a)
(assign byte-s (1- expt-diff))
(if (zero-fixnum (ldb-regs y-frac))
(sequential
(assign byte-r (- expt-diff))
(parallel
(assign byte-s (- 31@b expt-diff))
(if (minus-fixnum obus)
;;shifting to oblivion
(assign y-frac 0@a)
(assign y-frac (ldb-regs y-frac)))))
(sequential
(assign byte-r (- expt-diff))
(parallel
(assign byte-s (- 31@b expt-diff))
(if (minus-fixnum obus)
(assign y-frac (a-constant (field-mask frac-S-bit)))
(assign y-frac (logior (ldb-regs y-frac)
(b-constant (field-mask frac-S-bit))))))))))
(defmacro fadd-adjust-x-neg () ;7 cycles
`(sequential
(assign z-expt y-expt)
(assign byte-r 0@a)
(assign byte-s (- -1@b expt-diff))
(if (zero-fixnum (ldb-regs x-frac))
4,887,235
399 400
(sequential
(assign byte-r expt-diff)
(parallel
(assign byte-s (+ 31@b expt-diff))
(if (minus-fixnum obus)
(assign x-frac 0@a)
(assign x-frac (ldb-regs x-frac)))))
(sequential
(assign byte-r expt-diff)
(parallel
(assign byte-s (+ 3l@b expt-diff))
(if (minus-fixnum obus)
(assign x-frac (a-constant (field-mask frac-S-bit)))
(assign x-frac (logior (ldb-regs x-frac)
(a-constant (field-mask frac-S-bit))))))))))
(defmicro right-shift-z-by-1 () ;3 cycles
`(sequential
(assign z-expt (1+ z-expt))
(if (field-bit z-frac frac-S-bit)
(assign z-frac (logior 1@a (ldb z-frac 31. 1)))
(assign z-frac (ldb z-frac 31. 1)))))
(defmicro pack-and-return-z ()
`(sequential ;4 cycles
(assign b-temp (ldb-field z-frac frac-field))
(assign b-temp (dpb-field z-expt single-expt b-temp))
(assign b-temp (dpb-field b-temp single-except z-sign))
(parallel
(pop2push (set-type b-temp dtp-float))
(next-instruction))))
;;When z-expt <= 0, denormalize z-frac by right shifting -<z-expt> + 1 bits.
;;Costs 1 cycle in normal case.
(defmicro check-underflow (operation)
`(if (plus-fixnum z-expt)
(drop-through)
(sequential
(if (field-bit flonum-operating-mode trap-enable-underflow)
(flonum-trap-to-macrocode (signal-underflow) ,operation)
;;Ok, if z-expt is -n, we want to sticky-right-shift z-frac by n+1 bits.
(sequential
(flag-underflow)
(call normalize-z)
(assign byte-r 0@a)
(assign byte-s (- 2@b z-expt))
(if (zero-fixnum (ldb-regs z-frac))
(sequential
(assign byte-r (- z-expt 1@b))
(parallel
(assign byte-s (+ 30@b z-expt))
(if (minus-fixnum obus)
(assign z-frac 0@a)
(assign z-frac (ldb-regs z-frac)))))
(sequential
(assign byte-r (- z-expt 1@b))
(parallel
(assign byte-s (+ 30eb z-expt))
(if (minus-fixnum obus)
(assign z-frac (a-constant (field-mask frac-S-bit)))
(assign z-frac (logior (ldb-regs z-frac)
(a-constant (field-mask frac-S-bit))))))))
(assign z-expt 0@a))))))
;;Invalid-Operation if storing a unnormalized (but not denorsialized) result.
;; This is the case if N=0 and expt=0
:;Overflow if expt >= single-expt-max
;;Costs 2 cycles in the normal case.
(defmicro check-invalid-and-overflow (operation)
`(if (field-bit z-frac frac-N-bit)
(if (lesser-fixnum z-expt (b-constant single-expt-max))
(drop-through)
(flonum-trap-to-macrocode (signal-overflow) ,operation))
;;Here. we have an unnormalized fraction. It’s denormalized (and hence, Ok)
;;if its expt is zero.
(if (zero-fixnum z-expt)
(drop-through)
;XXXbrad - just stopped - obviously something missing
)))
;;;; Flonum add/subtract
(defucode fadd
(parallel
(trap-no-save)
(assign y-sign top-of-stack)
(jump fadd-common)))
(defucode fsub
(parallel
(trap-no-save)
4,887,235
401 402
(assign y-sign (logxor -1@a top-of-stack))
(jump fadd-common)))
(defucode fadd-common
(if-zero-fixnum-assignment (x-expt (ldb-field next-on-stack single-expt))
(assign x-frac (dpb-field next-on-stack frac-field-denormalized 0))
(if (equal-fixnum x-expt (a-constant single-expt-max))
(goto fadd-inf-or-nan)
(assign x-frac (+ (b-constant (field-mask frac-N-bit))
(dpb-field next-on-stack frac-field 0)))))
(if-zero-fixnum-assignment (y-expt (ldb-field top-of-stack single-expt))
;XXXbrad B?
(assign y-frac (dpb-field top-of-stack frac-field-denormalized B))
(if (equal-fixnum y-expt (b-constant single-expt-max))
(goto fadd-to-inf-or-nan)
(sequential
(assign b-temp (dpb-field top-of-stack frac-field
(a-constant (field-mask frac-N-bit))))
(assign y-frac b-temp))))
;;Adjust
(if-zero-fixnum-assignment (expt-diff (- x-expt y-expt))
(assign z-expt x-expt)
(if (minus-fixnum expt-diff)
(fadd-adjust-x-neg)
(fadd-adjust-y)))
;;Check signs
(if (not (minus-fixnum (logxor y-sign next-on-stack)))
;;signs the same, add magnitudes
(sequential
(assign z-sign y-sign)
(assign z-frac (+ x-frac y-frac))
(if (field-bit z-frac frac-V-bit)
(right-shift-z-by-1)
(if (zero-fixnum z-frac)
(goto fadd-resulted-in-zero)
(drop-through))))
;;signs differ, subtract magnitudes
(sequential
(if (plus-or-zero-fixnum y-sign)
(assign z-frac (- y-frac x-frac))
(assign z-frac (- x-frac y-frac)))
(if (zero-fixnum z-frac)
(goto fadd-resulted-in-zero) ;check for true zero vs. underflow
(if (minus-fixnum z-frac)
(sequential
(assign z-frac (- z-frac))
(assign 2-sign (a-constant (field-mask single-sign))))
(assign z-sign 0@a)))
;;Check whether input operands had been normalized
(assign b-temp (logior x-frac y-frac))
(if (field-bit b-temp frac-N-bit)
(call normalize-z)
(drop-through))))
(check-underflow fadd-operation)
(call single-round-z)
(check-invalid-and-overflow fadd-operation)
(pack-and-return-z))
;;;; Normalization
;;; Shift up to 4 bits at a whack. We try to pipeline something useful
;;; with take-dispatch, hence some of the hair here. Below, * represents
;;;a microcycle. (xxx;yyy) represents xxx and yyy done in parallel.
;;; Main Aux
;;; * Select dispatch * Select dispatch
;;; * Take dispatch * (Assign expt; Take dispatch, same as at left)
;;; 0: * (assign frac; jump aux)
;;; 1-7: * Assign frac
;;; * (Assign expt; return)
;;; 8-15: * Return
;;; We parallel
(defmicro z-normalize-steps (num)
`(sequential
(assign z-frac (rotate a-frac ,num))
(assign z-expt (- z-expt (b-constant ,num)))))
;; This is a micro so it can be shared between normalize-z and normalize-z-aux
;; next is the "next" that follows dispatch-after-next
(defmicro normalize-z-dispatch (next)
`(parallel
(dispatch-after-next (ldb-field z-frac frac-normalize-dispatch)
;;Dispatching on N.xxx
((0) ;0000
(parallel
(assign z-frac (rotate a-frac 4))
(jump normalize-z-aux)))
((1) ;0001
(parallel
(z-normalize-steps 3)
(return)))
4,887,235
403 404
((2 3) ;001x
(parallel
(z-normalize-steps 2)
(return)))
((4 5 6 7) ;01xx
(parallel
(z-normalize-steps 1)
(return))))
(if (greater-or-equal-fixnum-unsigned (ldb-field z-frac frac-normalize-dispatch)
(a-constant #o10))
(parallel ,next (return))
(parallel ,next (take-dispatch)))))
(defucode normalize-z
(normalize-c-dispatch ()))
(defucode normalize-z-aux
(normalize-z-dispatch
(assign z-expt (- z-expt (b-constant 4)))))
;;;; Rounding
(defmicro increment-z-frac-L-bit ()
`(sequential
(assign z-frac (+ z-frac (a-constant (field-mask frac-L-bit))))
(if (field-bit z-frac frac-V-bit)
(right-shift-z-by-1)
(drop-through))))
;;We dispatch on rounding mode combined uith the inexact-result-trap-enable bit,
;;so we ocn’t have to screw around deciding whether to trap.
(defucode single-round-z
(if (equal-fixnum (rounding-mode-with-inexact flonum-operating-mode)
rounding-mode-nearest)
;;r-ound z to nearest don’t try to trap on Inexact-Result
;;We can’t pull the IF/DISPATCH hack here because z-frac comes from B side
;;as must the internally-genorated constant for (if (zero-fixnum alub) ...)
(dispatch-after-this (ldb-field z-frac frac-round-dispatch)
(nop)
;; dispatching on LGRS: Sianal Inexact-Result unless CRS=0,
;; do nothing further when GRS < 4. When GPS=4 make the L bit zero
;; (i.e., 0100 ok, 1100 add 1 in L position). Otherwise, add 1 in L.
((0 10) ;0000, 1000
(return))
((1 2 3 4 #o11 #o12 #o13) ;0001, 001x,d. 0100, 1001, 101x
(flag-inexact-result-and-return))
((5 6 7 14 15 16 17) ;01xx, 11xx
(increment-z-frac-L-bit)
(flag-inexact-result-and-return)))
(drop-through))
(dispatch-after-this (rounding-mode-with-inexact flonum-operating-mode)
(nop)
;;rounding-mode-nearest is taken care of by the IF above
((rounding-mode-nearest-inexact) ;do trap on inexact result
(dispatch-after-this (ldb-field z-frac frac-round-dispatch)
(nop)
((0 10) ;0000, 1000
(return))
((1 2 3 4 #011 #o12 #o13) ;0001, 001x, 0100, 1001. 101x
(signal-inexact-result-and-trap))
((5 6 7 14 15 16 17) ;Olxx, llxx
(increment-z-frac-L-bit)
(signal-inexact-result-and-trap))))
((rounding-mode-zero)
(if (not-zero-fixnum (ldb-field z-frac frac-gre))
(flag-inexact-result-and-return)
(return)))
((rounding-mode-zero-inexact)
(if (not-zero-fixnum (ldb-field z-frac frac-grs))
(signal-inexact-result-and-trap)
(relurn)))
((rounding-mode-plus)
(if (plus-fixnum z-sign)
(goto single-round-z-up-nosignal)
(goto single-round-z-down-nosignal)))
((rounding-mode-plus-inexact)
(if (plus-fixnum z-sign)
(goto single-round-z-up-signal)
(goto single-round-z-down-signal)))
((rounding-mode-minus)
(if (plus-fixnum z-sign)
(goto single-round-z-down-nosignal)
(goto single-round-z-up-nosignal)))
((rounding-mode-minus-inexact)
(if (plus-fixnum z-sign)
(goto single-round-z-down-signal)
(goto single-round-z-up-signal)))))
(defucode single-round-z-up-nosignal
(if (zero-fixnum (ldb-field z-frac frac-grs))
(return)
4,887,235
405 406
(sequential
(increment-z-frac-L-bit)
(flag-inexact-result-and-return))))
(defucode single-round-z-up-signal
(if (zero-fixnum (ldb-field z-frac frac-grs))
(return)
(sequential
(increment-z-frac-L-bit)
(signal-inexact-result-and-trap))))
(defucode single-round-z-down-nosignal
(if (zero-fixnum (ldb-field z-frac frac-grs))
(flag-inexact-result-and-return)
(return)))
(defucode single-round-z-down-signal
(if (zero-fixnum (ldb-field z-frac frac-grs))
(signal-inexact-result-and-trap)
(return)))
;;;; fadd exceptional oases
;;Might as well save a ucode space word everywhere, as well.
(defucode flag-flonum-operating-mode
(parallel
(assign flonum-operating-mode
(logior flonum-operating-mode b-temp))
(return)))
(defucode fadd-resulted-in-zero
(if (equal-fixnum (ldb-field flonum-operating-mode rounding-mode)
rounding-made-minus)
(assign z-sign (a-constant (field-mask single-sign)))
(assign z-sign 0@a))
;;If either operand was normalized after binary point alignment, set the exponent
;;to minimum value, i.e., true zero. If neither was, leave the expt alone, so
;;an Underflow trap will occur when storing the result is attempted.
(assign b-temp (logior x-frac y-frac))
(if (field-bit b-temp frac-N-bit)
(parallel
(pop2push (set-type z-sign dtp-float))
(next-instruction))
(if (zero-fixnum b-temp) ;both operands were zero
(parallel
(pop2push (set-type z-sign dtp-float))
(next-instruction))
(flonum-trap-to-macrocode (signal-underflow) fadd-operation))))
(defucode push-z-and-trap-to-macrocode
(pushval (set-type z-frac dtp-fix))
(pushval (set-type z-expt dtp-fix))
(pushval (set-type z-sign dtp-fix))
(jump trap-to-macrocode))
(defucode fadd-inf-or-nan
(flonum-trap-to-macrocode (signal-invalid-operation) fadd-operation))
(defucode fadd-to-inf-or-nan
(flonum-trap-to-macrocode (signal-invalid-operation) fadd-operation))
(defucode trap-to-macrocode ;--- someone should write this
(signal-error-no-restore-stack floating-point-trap-to-macrocode))
;;; Scaling
;If there is any exception, we just trap to the macrocoded ash, which is perhaps wrong
(defucode ash-float
;; First check for exceptional cases
(if (zero-fixnum (ldb-field next-on-stack single-except-sign)) ;0.0 or -0.0
(parallel
(pop2push next-on-stack)
(next-instruction))
(drop-through))
(if (zero-fixnum (ldb-field next-on-stack single-expt))
(goto ash-overflow)
(drop-through))
(if (equal-fixnum (ldb-field next-on-stack single-expt) (b-constant single-expt-max))
(goto ash-overflow)
(drop-through))
;; Scale the exponent
(assign b-temp (+ (ldb-field next-on-stack single-expt) top-of-stack))
(if (plus-fixnum b-temp)
(if (lesser-fixnum b-temp (a-constant single-expt-max))
(parallel
(pop2push (set-type (dpb-field b-temp single-expt next-on-stack) dtp-float))
(next-instruction))
(goto ash-overflow)) ;expanent overflow
(goto ash-overflow))) ;exponent under-flow
; 5 4 3 2 1 0
; 321.987654321.98765432|1.987654321.987654321.987654321.
; n....................|...grsn.......................grx without V
; 654321.987654321.9876|54321.
; .987654321.987654321.|
4,887,235
407 408
; n.....................|..grsn.......................grs with V
; 654321.987654321.98765|4321.
; 1.987654321.987654321.|
; 321.987654321.98765432|1.987664321.987654321.987654321.
; 5 4 3 2 1 0
(defsysbyte fmul-lo-lost 26. 0)
(defsysbyte fmul-lo-take 6 26.)
(defsysbyte fmul-hi-take 21. 0)
(defsysbyte fmul-hi-put 21. 6)
(defsysbyte fmul-hi-V-bit 1 21.)
(defsysbyte fmul-lo-lost-V 27. 0)
(defsysbyte fmul-lo-take-V 5. 27.)
(defsysbyte fmul-hi-take-V 22. 0)
(defsysbyte fmul-hi-put-V 22. 5)
(defatomicro fmul-hi-part expt-diff)
(defatomicro fmul-lo-part b-low-dividend)
;;to pass to mpy-32-32 which wants routines
(defmicro fmul-store-hi-part (x)
`(assign fmul-hi-part ,x))
(defmicro fmul-store-lo-part (x)
`(assign fmul-lo-part ,x))
(defucode fmul
(parallel (if-zero-fixnum-assignment (x-expt (ldb-field next-on-stack single-expt))
(assign x-frac (dpb-field next-on-stack frac-field-denormalized 0))
(if (equal-fixnum x-expt (a-constant single-expt-max))
(gato fmul-inf-or-nan)
(assign x-frac (+ (b-constant (field-mask frac-N-bit))
(dpb-field next-on-stack frac-field B)))))
(trap-no-save))
(if-zero-fixnum-assignment (y-expt (ldb-field top-of-stack single-expt))
(assign y-frac (dpb-field top-of-stack frac-field-denormalized 0))
(if (equal-fixnum y-expt (b-constant single-expt-max))
(goto fmul-to-inf-or-nan)
(sequential
(assign b-temp (dpb-field top-of-stack frac-field
(a-constant (field-mask frac-N-bit))))
(assign y-frac b-temp))))
(assign z-sign (logxor top-of-stack next-on-stack))
(mpy-32-32 y-frac x-frac
fmul-store-lo-part fmul-store-hi-part
())
(if (field-bit fmul-hi-part fmul-hi-V-bit)
(sequential
(assign z-expt (+ x-expt y-expt 1))
(if (zero-fixnum (ldb-field fmul-lo-part fmul-lo-lost-V))
(assign z-frac (ldb-field fmul-lo-part fmul-lo-take-V))
(assign z-frac (logior 1@a (ldb-field fmul-lo-part fmul-lo-take-V))))
(assign z-frac (dpb-field fmul-hi-part fmul-hi-put-V z-frac)))
(sequential
(assign z-expt (+ x-expt y-expt))
(if (zero-fixnum (ldb-field fmul-lo-part fmul-lo-lost))
(assign z-frac (ldb-field fmul-lo-part fmul-lo-take))
(assign z-frac (logior 1@a (ldb-field fmul-lo-part fmul-lo-take))))
(assign z-frac (dpb-field fmul-hi-part fmul-hi-put z-frac))))
(if (not-zero-fixnum z-frac)
(sequential
(assign z-expt (- z-expt (b-constant single-expt-bias)))
(check-underflow fmul-operation))
(assign c-expt 0@a))
(call single-round-z)
(check-invalid-and-overflow fmul-operation)
(pack-and-return-z))
(defucode fmul-inf-or-nan
(flonum-trap-to-macrocode (signal-invalid-operation) fmul-operation))
(defucode fmul-to-inf-or-nan
(flonum-trap-to-macrocode (signal-invalid-operation) fmul-operation))
;;divisar is top-of-stack (b) moved to y
;;dividend is next-on-stack (a) moved to x
; 5 4 3 2 1 0
; 321.987654321.98765432|1.987654321.987654321.987654321.
; n.................|.....|grs?......................| ;dividend, upper
; 321.987654321.9876|54321.
; 7654321.987654321.|
; | n.......................| ;divisor
; 321.987654321.98765432|1.987654321.987654321.987654321.
; 5 4 3 2 1 0
(defsysbyte fdiv-hi-take 17. 6) ;dividend
(defsysbyte fdiv-lo-put 6 26.)
(eval-when (eval compile load)
(defconst fdiv-hi-N-bit (ash 1 17.))
)
4,887,235
409 410
(defucode fdiv
;;hack the divisor
(parallel
(if-zero-fixnum-assignment (y-expt (ldb-field top-of-stack single-expt))
(goto fdiv-by-zero-or-denorm)
(if (equal-fixnum y-expt (b-constant single-expt-max))
(goto fdiv-by-inf-or-nan)
(sequential
(assign a-positive-divisor (ldb-field top-of-stack single-frac))
(assign a-positive-divisor
(logior a-positive-divisor (b-constant (field-mask single-N-bit))))
(assign a-negative-divisor (- a-positive-divisor)))))
(trap-no-save))
;;hack the dvidend
(if-zero-fixnum-assignment (x-expt (ldb-field next-on-stack single-expt))
;; Divisor is normal, but dividend is zero or denormaliced
(if (zero-fixnum (ldb-field next-on-stack single-frac))
;; Zero divided by non-zero is zero, with xor- of opcr-and& signo
(sequential
(assign b-temp (dpb-field (b-constant 0) single-except-sign top-of-stack-a))
(parallel (pop2push (set-type (logxor next-on-stack b-temp) dtp-float))
(next-instruction)))
;; Dividend is denormalized
(goto fdiv-into-denorm))
;; Dividend and divisor are normal
(if (equal-fixnum x-expt (a-constant single-expt-max))
(goto fdiv-into-inf-or-nan)
(sequential
(assign b-high-dividend
(logior (ldb-field next-on-stack fdiv-hi-take)
(b-constant fdiv-hi-N-bit)))
(assign b-low-dividend (dpb-field next-on-stack fdiv-lo-put 8)))))
(parallel
;;15. - 32./2-1. see call to divide-routine in the DIVISION file.
;;consider shifting operands to reduce this to 24./2-1 somehow.
(assign a-divide-step-count (a-constant 15.))
(call divide-subroutine)) ;leave quo in b-tow-dividend, and rem in b-high-dividend.
;;if there was a remainder, set the sticky bit for rounding; and move to z-frac for
;;single-round-z.
;;--- figure a good way to fold this in with the rounding??
(if (not-zero-fixnum b-high-dividend)
(assign z-frac (logior b-low-dividend (a-constant (field-mask frac-S-bit))))
(assign z-frac b-low-dividend))
;;If quotient N-bit is zero, then left-shift quo by 1 and decr its expt
(if (field-bit b-low-dividend frac-N-bit)
(assign z-expt (- x-expt y-expt))
(sequential
(assign z-expt (- x-expt y-expt 1))
(assign z-frac (rotate z-frac 1))))
(assign z-expt (+ z-expt (b-constant single-expt-bias)))
(assign z-sign (logxor next-on-stack top-of-stack))
(check-underflow fdiv-operation)
(call single-round-z)
(check-invalid-and-overflow fdiv-operation)
(pack-and-return-z))
(defucode fdiv-by-zero-or-denorm
(flonum-trap-to-macrocode (signal-invalid-operation) fdiv-operation))
(defucode fdiv-by-inf-or-nan
(flonum-trap-to-macrocode (signal-invalid-operation) fdiv-operation))
(defucode fdiv-into-denorm
(flonum-trap-to-macrocode (signal-invalid-operation) fdiv-operation))
(defucode fdiv-into-inf-or-nan
(flonum-trap-to-macrocode (signal-invalid-operation) fdiv-operation))
;;; Convert fixnum on top of stack to flonum on top of stack
;;;Traps to macrocode arent really going to work, yet.
(eval-when (eval compile load)
(defconst *setz-as-flonum* ;setz here being -1_31.
(dpb-field 1 single-sign
(dpb-field (+ single-expt-bias 31.) single-expt 0)))
);eval-when eval-compile-load
(defucode convert-fixnum-to-flonum
(if (minus-fixnum top-of-stack)
(if (zero-fixnum (ldb top-of-stack 31. 0)) ;setz?
(parallel
(newtop (set-type (b-constant *setz-as-flonum*) dtp-float))
(return))
(sequential
(assign z-sign (b-constant 1_31.))
(assign b-temp (- top-of-stack))))
(if (zero-fixnum top-of-stack)
(parallel
(newtop (set-type (b-constant 0) dtp-float))
(return))
(sequential
(assign z-sign (b-constant 0))
(assign b-temp top-of-stack))))
(if (zero-fixnum (ldb b-temp 4 27.)) ;the bits above frac-n-bit
4,887,235
411 412
;;they are zero, no sweat
(sequential
(assign z-expt (b-constant (+ single-expt-bias 26.))) ;26. is how far to shift 1 -> N
(assign z-frac b-temp))
;;same bits up there, need to shift right by 4 to clear then
(sequential
(assign z-expt (b-constant (+ single-expt-bias 26. 4))) ;yes
(if (zero-fixnum (ldb b-temp 4 0)) ;is sticky bit adjustment necessary?
(assign z-frac (ldb b-temp 28. 4)) ;no
(assign z-frac (logior (ldb b-temp 28. 4) (a-constant 1))))))
(call normalize-z) ;bum a couple cycles here somehow?
(call single-round-z)
(assign b-temp (ldb-field z-frac frac-field))
(assign b-temp (dpb-field z-expt single-expt b-temp))
(assign b-temp (dpb-field b-temp single-except-sign z-sign))
(parallel
(newtop (set-type b-temp dtp-float))
(return)))
;;; Compare flonums: Returns positive number if the first is greater- than the second
;;; neqative number if the second is greater than the first, and 0 if they are equal
(defucode flonum-compare
(if (zero-fixnum (ldb-field next-on-stack single-expt))
(assign x-frac (dpb-field next-on-stack single-frac 0))
(assign x-frac next-on-stack))
(if (zero-fixnum (ldb-field top-of-stack-a single-expt))
(assign y-frac (dpb-field top-of-stack-a single-frac 0))
(assign y-frac top-of-stack-a))
(if (equal-fixnum (ldb-field next-on-stack single-expt) (b-constant single-expt-max))
(goto compare-first-inf-or-nan)
(drop-through))
(if (equal-fixnum (ldb-field top-of-stack-a single-expt) (b-constant single-expt-max))
(goto compare-second-inf-or-nan)
(drop-through))
;; This crap is because of signed magnitude lossage
(if (minus-fixnum x-frac)
(if (minus-fixnum y-frac)
;; Both negative, larger if xfrac < y-frac
(parallel (pop2push (set-type (- y-frac x-frac) dtp-fix))
(return))
;; First is neoative, second is positive
(parallel (pop2push (set-type (b-constant -1) dtp-fix))
(return)))
(if (minus-fixnum y-frac)
;; First is positive, second is negative
(parallel (pop2push (set-type (b-constant 1) dtp-fix))
(return))
;; Both positive la.r-oer- if x-frac > y-frac
(parallel (pop2push (set-type (- x-frac y-frac) dtp-fix))
(return)))))
(defucode fgreaterp
(parallel (nop) (trap-no-save)) ;Cannot call in first cycle after trap
(call flonum-compare)
(if (plus-fixnum top-of-stack-a)
(goto true1)
(goto false1)))
(defucode flessp
(parallel (nop) (trap-no-save)) ;Cannot call in first cycle after trap
(call flonum-compare)
(if (minus-fixnum top-of-stack-a)
(goto true1)
(goto false1)))
(defucode fequal
(parallel (nop) (trap-no-save)) ;Cannot call in fir-st cycle after- trap
(call flonum-compare)
(if (zero-fixnum top-of-stack-a)
(goto true1)
(goto false1)))
;;; Signum of flonums:
;;; (This is not the SIGNUM function, since it returns a fixnum, not a flonum)
(defucode fsignum
(if (zero-fixnum (ldb-field top-of-stack-a signal-except-sign))
(parallel (newtop (set-type (b-constant 0) dtp-fix))
(return))
(drop-through))
(if (equal-fixnum (ldb-field top-of-stack-a single-expt) (b-constant single-expt-max))
(goto signum-inf-or-nan)
(drop-through))
(if (minus-fixnum top-of-stack-a)
(parallel (newtop (set-type (b-constant -1) dtp-fix))
(return))
(parallel (newtop (set-type (b-constant 1) dtp-fix))
(return))))
;;; These could be bummed one cycle if fsignum was not signum, but just returned
;;; the argument except with zero
(defucode fplusp