;;;-*- Mode:LISP; Package:NEW-MATH; Base:10; Readtable:CL -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum multiply ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun multiply-fixnum (x y) (hw::load-q-register x) (let* ((high-half ;;a fixnum (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-first-step y 0))))))))))))) (low-half (hw::read-q-register-boxed)) ;;a fixnum (sign (hw::ldb low-half vinc:%%fixnum-sign-bit 0))) (if (zerop (hw:24+ high-half sign)) low-half ;; We overflowed, make a bignum (let ((bignum-high (hw:32arithmetic-shift-down (hw:32-sign-extend high-half) (byte-size vinc:%%fixnum-non-data))) (bignum-low (hw:dpb-unboxed high-half vinc:%%fixnum-non-data low-half))) (if (hw:32zerop (hw:32+ bignum-high (hw:ldb bignum-low vinc:%%bignum-sign-high-word gr:*all-zero*))) (make-bignum-32-get-neg-status bignum-low) (make-bignum-64-get-neg-status bignum-high bignum-low)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum divide ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun divide-fixnum (dividend divisor) (when (zerop divisor) (li:error "Zero divide" dividend divisor)) ;;Seems like we need to load-q-reg here. --wkf (let* ((almost-remainder (hw:signed-divide-last1 divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-first-step divisor (hw:24-sign-fill (hw:load-q-register dividend)) )))))))))))))))))))))))))) (cruft (hw:signed-divide-last2 divisor almost-remainder)) (remainder(hw:remainder-correct divisor almost-remainder)) (quotient (hw:quotient-correct (hw:read-q-register-boxed)))) (if (hw:alu-status-logbitp (byte-position hw:%%alu-status-overflow)) (values quotient remainder) (values (array:make-bignum-32 (hw:unboxed-constant (- li:most-negative-fixnum))) remainder)))) (defun truncate-fixnum (dividend divisor) (divide-fixnum dividend divisor)) (defun floor-fixnum (dividend divisor) (multiple-value-bind (quotient remainder) (divide-fixnum dividend divisor) (if (or (and (minusp quotient) (not (zerop remainder))) (minusp remainder)) (values (1- quotient) (+ remainder divisor)) (values quotient remainder)))) (defun ceiling-fixnum (dividend divisor) (multiple-value-bind (quotient status remainder) (divide-fixnum dividend divisor) (if (or (and (plusp quotient) (not (zerop remainder))) (plusp remainder)) (values (1+ quotient) (- remainder divisor)) (values quotient remainder)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum add that may overflow ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun add-fixnum (x y) (let ((sum24 (hw:24+ x y)) (status (hw:read-alu-status))) (if (hw:32logbitp (byte-position hw:%%alu-status-overflow) status) (make-bignum-32-get-neg-status (hw:32+ (hw:32-sign-extend x) (hw:32-sign-extend y))) (values sum24 status)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum subtract that may overflow ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun subtract-fixnum (x y) (let ((diff24 (hw:24- x y)) (status (hw:read-alu-status))) (if (hw:32logbitp (byte-position hw:%%alu-status-overflow) status) (make-bignum-32-get-neg-status (hw:32- (hw:32-sign-extend x) (hw:32-sign-extend y))) (values diff24 status)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum compare ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compare-fixnum (x y) (values (hw:24- x y) (hw:read-alu-status))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum compare ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun test-fixnum (x) (values x (hw:read-alu-status))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum negate that may overflow ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun negate-fixnum (x) (if (= x li:most-negative-fixnum) (values (array:make-bignum-32 (hw:unboxed-constant #x800000)) hw:$$alu-status-positive)) (values (- x) (hw:read-alu-status))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum field pass ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun field-pass-fixnum (x y byte-spec ldb-p) (multiple-value-bind (hard size position) (resolve-byte-spec byte-spec ldb-p) (if hard (field-pass-bignum-internal (convert-fixnum-to-bignum x) (convert-fixnum-to-bignum y) position size) ;; (ALU FIELD-PASS ...) ;; does dpb if (byte-position byte-spec) is positive ;; does ldb if (byte-position byte-spec) is negative ;; pfc 5/25 (values (if ldb-p (hw:ldb x byte-spec y) (hw:dpb x byte-spec y)) (hw:read-alu-status))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Resolve byte specifier ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun resolve-byte-spec-internal (bs ldb-p) (multiple-value-bind (size position) (if (vinc:fixnump bs) (let ((fsize (hw:ldb bs vinc:%%byte-size 0))) (values (if (zerop fsize) 32. fsize) (li:byte-position-fixnum bs))) (values (cons:car bs) (cons:cdr bs))) (when (< size 1) ;;move inside m-v-b --wkf@@@ (li:error "Illegal size in byte specifier" size)) (when ldb-p (setq position (- position))) (values size position))) (defun resolve-byte-spec (bs ldb-p) (multiple-value-bind (size position) (resolve-byte-spec-internal bs ldb-p) ; fixed --pfc 4/25 (if (or (and (<= position 0) ; big ldb's are hard (<= (- size position) 24.)) ; allowed to ldb from sign bit !! (and (not (minusp position)) ; big dpb's are hard (<= (+ position size) 23.))) ; not allowed to dpb into sign bit !! (values nil size position) ; not hard (values t size position)))) ; hard ;(defun byte-position (bs) ;;@@@ Do we need definition other than one in arithmetic.lisp? --wkf ; (if (vinc:fixnump bs) ; (li:byte-position-fixnum bs) ; (cons:cdr bs))) ;(defun byte-size (bs) ;;@@@ Do we need definition other than one in arithmetic.lisp? --wkf ; (if (vinc:fixnump bs) ; (let ((fsize (hw:ldb bs vinc:%%byte-size 0))) ; (if (zerop fsize) 32. fsize)) ; (cons:car bs))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum ash ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ash-fixnum (i shift) (unless (vinc:fixnump shift) (li:error "Bad shift to ash, must be a fixnum" i shift)) (%ash-fixnum i shift)) ;; See the code following for a lisp version of %ash-fixnum. --wkf ;; a0 --- i number to be ashed ;; a1 --- shift amount of shift, a fixnum ;; locals: ;; a3 -- the result ;; a4 -- number of bits which are unused in i ;; a5 -- (abs i) absolute value of number to be ashed ;; a6 -- 32 bit sign extended fixnum i ;; Returns (values (ash i shift) (status of (ash i shift))) (defafun %ash-fixnum (i shift) ;;;Written by --wkf using fleabit output. (ALU SETR NOP A1 A1 BW-24 BOXED DT-BOTH-FIXNUM) ;; if (minusp shift) (ALU SETR NOP A0 A0 BW-24 BOXED DT-BOTH-FIXNUM BR-NEGATIVE) ;; if (not (minusp i)) (BRANCH negative-shift (ALU SEX-R A6 A0 A0 BW-24 UNBOXED) BR-NOT-NEGATIVE) ;; branch if (minusp shift) (BRANCH find-unused-bits (MOVE A5 A0 BOXED-RIGHT)) ;; branch if (not (minusp i)) (ALU L-R A5 (REGISTER *ZERO* 4 0) A0 BW-24 BOXED DT-BOTH-FIXNUM-WITH-OVERFLOW) find-unused-bits ;; make i positive (negate it.) (ALU PRIORITIZE-R A4 A5 A5 BW-24 UNBOXED) ;; Find unused bits of (abs i) sets Z bit if 0 input. (ALU L-R NOP A1 A4 BW-24 DT-NONE BR-NOT-ZERO) ;; Test for (zerop (abs i)) and will shift make bignum (BRANCH bignum-test (ALU L-R NOP A1 A4 BW-24 DT-NONE) BR-NOT-GREATER-OR-EQUAL);; return-zero ;; (when (>= shift unused-bits) (cons-a-bignum)) (MOVEI (REGISTER *NUMBER-OF-RETURN-VALUES* 11 15) (QUOTE 2) BOXED) ;; (ash 0 n)  0 (MOVEI (REGISTER *RETURN-0* 10 0) (QUOTE 524288) BOXED) (MOVE RETURN-MV (REGISTER *ZERO* 4 0) BOXED-RIGHT CH-RETURN NEXT-PC-RETURN) bignum-test (BRANCH simple-shift (ALU LOAD-STATUS-R NOP IGNORE A1 BW-8)) ;; Put low byte of shift into status register cons-a-bignum (OPEN-CALL (CONVERT-FIXNUM-TO-BIGNUM 1) (NEW-TAIL-OPEN 0) (O0 A0 BOXED-RIGHT)) (TAIL-CALL (ASH-BIGNUM 2) (O1 A1 BOXED-RIGHT)) negative-shift ;; find (max shift -32), assuming negative shift (ALU-FIELD ALIGNED-FIELD-XOR NOP A1 (REGISTER *ALL-ONES* 4 7) (QUOTE 4869) PW-II) ;; (< shift -32), assuming negative shift (TEST BR-EQUAL) (BRANCH simple-shift (ALU LOAD-STATUS-R NOP IGNORE A1 BW-8)) ;; Put low byte of shift into status register (MOVEI A1 (QUOTE -32) BOXED) (ALU LOAD-STATUS-R NOP IGNORE A1 BW-8) ;;;@@@ Is this needed again? ;; Put low byte of shift into status register simple-shift (ALU-FIELD NB-SHIFT-AR-R A6 IGNORE A6 (QUOTE 0) PW-RR) ;; Arithmetically Shift Sign extended fixnum by shift (ALU-FIELD FIELD-PASS A3 (REGISTER *ONE* 4 1) A6 (QUOTE 1562) PW-II DT-NONE BOXED) ;; Make a fixnum (ALU PASS-STATUS A2 ignore ignore BW-24 BOXED) ;;@@@ Fold this in? ;; Get status of last previous fixnum (MOVEI (REGISTER *NUMBER-OF-RETURN-VALUES* 11 15) (QUOTE 2) BOXED) (MOVE (REGISTER *RETURN-0* 10 0) A2) (MOVE RETURN-MV A3 BOXED-RIGHT CH-RETURN NEXT-PC-RETURN)) #|||| ;;The following code is a model of the previous defafun. --wkf (defun %ash-fixnum (i shift) (if (minusp shift) (unless (hw:field= shift gr:*all-ones* (byte 19. 5.)) ;;  (< shift -32), assuming negative shift (setq shift -32)) (let* ((abs-i (if (minusp i) (- i) i)) (unused-bits (vinc:make-fixnum (hw:24-prioritize abs-i)))) ;;24-prioritize sets Z bit if zero input. ;;@@@ We can branch here using result of 24-prioritize instead, saving 1 instuction --wkf (cond ((zerop unused-bits) ;;;  (= i 0) (return-from %ash-fixnum (values 0 hw:$$alu-status-zero))) ((>= shift unused-bits) (return-from %ash-fixnum (ash-bignum (convert-fixnum-to-bignum i) shift)))))) (values ;;This case is for all negative and safe (small) positive shifts. --wkf (vinc:make-fixnum (hw:32arithmetic-shift-up (hw:32-sign-extend i) shift)) (hw:read-alu-status))) ||||# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum logand ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun logand-fixnum (x y) (logand x y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum logior ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun logior-fixnum (x y) (logior x y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum logxor ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun logxor-fixnum (x y) (logxor x y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum logxnor ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun logxnor-fixnum (x y) (logeqv x y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum lognot ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun lognot-fixnum (x) (lognot x)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; For slightly large fixnums ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;********************************** ;;;* * ;;;* ALLOCATING STORAGE FOR BIGNUMS * ;;;* * ;;;********************************** (defun allocate-bignum (size) (unless (and (plusp size) (< size #x40000)) (li:error "Bad size to allocate-bignum" size)) (%allocate-bignum size)) (defun %allocate-bignum (size) (cons::allocate-structure 1 size $$dtp-bignum (cons:make-header $$dtp-unboxed-header size))) ;;;********************************** ;;;* * ;;;* SHRINK BIGNUM STRUCTURE * ;;;* * ;;;********************************** (defun shrink-bignum-structure (bignum) (let* ((size (hw:dpb-boxed (%vm-read bignum) vinc:%%bignum-words gr:*zero*)) (high-word (%vm-read24 bignum size)) (new-size size)) (labels ((reduce-bignum (new-size new-high-word) (if (= 1 new-size) (if (or (hw:field= new-high-word gr:*all-zero* vinc:%%fixnum-sign-and-datatype) (hw:field= new-high-word (hw:unboxed-constant #xFF800000) vinc:%%fixnum-sign-and-datatype)) (values (hw:ldb-boxed new-high-word vinc::%%fixnum-field 0) (hw:read-alu-status)) (gc-bignum bignum new-size new-high-word)) (let* ((next-size (1- new-size)) (next-word (%vm-read24 bignum next-size))) (if (hw:32zerop (hw:32+ new-high-word (hw:ldb next-word vinc:%%bignum-sign-high-word gr:*all-zero*))) (reduce-bignum next-size next-word) (gc-bignum bignum new-size new-high-word))))) (gc-bignum (bignum new-size new-high-word) (let ((first-gc-word (1+ new-size))) (%vm-write24 bignum first-gc-word (cons:make-header $$dtp-unboxed-header (- size first-gc-word)))) ;;+++ Above is ready to be garbage collected. Should we have a special datatype for this? --wkf (%vm-write bignum (cons:make-header $$dtp-unboxed-header new-size)) (values bignum (hw:dpb (hw:ldb new-high-word vinc:%%bignum-sign-high-word 0) hw:%%alu-status-negative 0)))) (reduce-bignum size high-word)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Allocate Bignums and get their status, negative or positive, don't check for zero. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun make-bignum-32-get-neg-status (bignum-word) "Does not detect zero status." (let ((ptr (cons:allocate-structure 1 1 $$dtp-bignum (cons:make-header $$dtp-unboxed-header 1)))) (%vm-write24 ptr 1 bignum-word) (values ptr (hw:dpb (hw:ldb bignum-word vinc:%%bignum-sign-high-word 0) hw:%%alu-status-negative 0)))) (defun make-bignum-64-get-neg-status (bignum-word-high bignum-word-low) "Does not detect zero status." (let ((ptr (cons:allocate-structure 1 2 $$dtp-bignum (cons:make-header $$dtp-unboxed-header 2)))) (%vm-write24 ptr 1 bignum-word-low) (%vm-write24 ptr 2 bignum-word-high) (values ptr (hw:dpb (hw:ldb bignum-word-high vinc:%%bignum-sign-high-word 0) hw:%%alu-status-negative 0))))