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 - + 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