;;;-*- Mode:LISP; Package:NEW-MATH; Base:10; Readtable:CL -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum multiply ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun multiply-fixnum (x y) (hw::load-q-register x) (let* ((high-half (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)) (sign (hw::ldb low-half (byte 1. 31.) 0))) (if (zerop (hw:24+ high-half sign)) low-half ;; We overflowed, make a bignum (let ((biggy (allocate-bignum 2))) (hw:write-md-unboxed (hw:dpb-unboxed high-half (byte 8. 24.) low-half)) (hw:vma-start-write-no-gc-trap-unboxed (hw:32-1+ biggy)) (hw:write-md-unboxed (hw:32arithmetic-shift-down (hw:32-sign-extend high-half) 8.)) (hw:vma-start-write-no-gc-trap-unboxed (hw:32-2+ biggy)) (shrink-bignum-structure biggy))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum divide ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun divide-fixnum (dividend divisor) (if (zerop divisor) (trap::illop "Zero divide") (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 (not (hw:alu-status-logbitp hw:%%alu-status-overflow)) (let ((biggy (allocate-bignum 2))) (hw:write-md-unboxed (hw:unboxed-constant #x80000000)) (hw:vma-start-write-no-gc-trap-unboxed (hw:32-1+ biggy)) (hw:memory-wait) (hw:write-md-unboxed (hw:unboxed-constant 0)) (hw:vma-start-write-no-gc-trap-unboxed (hw:32-2+ biggy)) (values biggy remainder)) (values quotient 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 (and (minusp quotient) (not (zerop 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 (and (not (minusp quotient)) (not (zerop 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 hw:%%alu-status-overflow status) (let ((biggy (allocate-bignum 1))) (hw:write-vma-unboxed (hw:32-1+ biggy)) (hw:md-start-write-no-gc-trap-unboxed (hw:32+ (hw:32-sign-extend x) (hw:32-sign-extend y))) (values biggy (hw:read-alu-status))) (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 hw:%%alu-status-overflow status) (let ((biggy (allocate-bignum 1))) (hw:write-vma-unboxed (hw:32-1+ biggy)) (hw:md-start-write-no-gc-trap-unboxed (hw:32- (hw:32-sign-extend x) (hw:32-sign-extend y))) (values biggy (hw:read-alu-status))) (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 (hw:24- x 0) (hw:read-alu-status))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum negate that may overflow ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun negate-fixnum (x) (if (= x -8388608.) (let ((biggy (allocate-bignum 1))) (hw:write-vma-unboxed (hw:32-1+ biggy)) (hw:md-start-write-no-gc-trap-unboxed (hw:unboxed-constant #x800000)) (values biggy (hw:read-alu-status))) (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 (convert-fixnum-to-bignum x) (convert-fixnum-to-bignum y) byte-spec ldb-p) (values (hw:dpb x byte-spec y) (hw:read-alu-status))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Resolve byte specifier ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun resolve-byte-spec (bs ldb-p) (multiple-value-bind (size position) (if (hw:field= bs gr:*zero* vinc::%%data-type) ;fixnum --> short format byte spec (let ((fsize (hw:ldb bs (byte 5. 8.) 0))) (values (if (zerop fsize) 32. fsize) (hw:dpb-boxed vinc:$$dtp-fixnum vinc::%%data-type (hw:32arithmetic-shift-down (hw:dpb-unboxed bs (byte 8. 24.) gr:*all-zero*) 24.)))) (values (cons:car bs) (cons:cdr bs))) (when (< size 1) (trap:illop "Illegal size in byte specifier")) (when ldb-p (setq position (- position))) (if (or (and (<= position 0) ;so are big ldb's (< 24. (- size position))) (and (not (minusp position)) ;and big dpb's (< (+ position size) 23.))) (values nil size position) ; not hard (values t size position)))) ; hard (defun byte-position (bs) (if (hw:field= bs gr:*zero* vinc::%%data-type) (hw:dpb-boxed gr:*zero* vinc::%%data-type (hw:32arithmetic-shift-down (hw:dpb-unboxed bs (byte 8. 24.) gr:*all-zero*) 24.)) (cons:cdr bs))) (defun byte-size (bs) (if (hw:field= bs gr:*zero* vinc::%%data-type) (let ((fsize (hw:ldb bs (byte 5. 8.) 0))) (if (zerop fsize) 32. fsize)) (cons:car bs))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum ash ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ash-fixnum (i shift) (when (not (hw:field= shift gr:*zero* vinc::%%data-type)) (trap:illop "Bad shift to ash")) (let* ((big-i (hw:32-sign-extend i))) (if (minusp shift) (let ((x-shift (if (< shift -24.) -32. shift))) (values (hw:dpb-boxed (hw:32arithmetic-shift-down big-i x-shift) (byte 24. 0.) gr:*zero*) (hw:read-alu-status))) (let* ((raw-i (if (minusp i) (hw:ldb-not i (byte 24. 0.) 0) i)) (unused-bits (hw:dpb-boxed vinc:$$dtp-fixnum vinc::%%data-type (hw:24-prioritize raw-i)))) (if (>= shift unused-bits) (ash-bignum (convert-fixnum-to-bignum i) shift) (values (hw:dpb-boxed (hw:32logical-shift-up big-i shift) (byte 24. 0.) gr:*zero*) (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) (if (or (<= size 0) (>= size #x040000)) (trap:illop "Bad size to allocate-bignum") (cons::allocate-structure 1 size $$dtp-bignum (hw:dpb-unboxed $$dtp-unboxed-header vinc::%%data-type size)))) ;;;********************************** ;;;* * ;;;* SHRINK BIGNUM STRUCTURE * ;;;* * ;;;********************************** (defun shrink-bignum-structure (bignum-ptr) (let* ((size (progn (hw:vma-start-read-vma-boxed-md-boxed bignum-ptr) (hw:ldb (hw:read-md) vinc::%%fixnum-field 0))) (high-word (progn (hw:vma-start-read-no-transport-vma-unboxed-md-unboxed (hw:32+ size bignum-ptr)) (hw:read-md)))) (labels ((reduce-bignum () (if (= size 1) (progn (hw:write-md-unboxed (hw:dpb-unboxed $$dtp-unboxed-header vinc::%%data-type size)) (hw:vma-start-write-no-gc-trap-unboxed bignum-ptr) (if (zerop (hw:ldb (+ (hw:ldb high-word (byte 8. 24.) 0) (hw:ldb high-word (byte 1. 23.) 0)) (byte 8. 0.) 0)) (values (+ 0 (hw:ldb high-word vinc::%%fixnum-field 0)) (hw:read-alu-status)) (values bignum-ptr (hw:dpb (hw:ldb high-word (byte 1. 31.) 0) (byte 1. 17.) 0)))) (let ((next-word (progn (hw:vma-start-read-no-transport-vma-unboxed-md-unboxed (hw:32+ (1- size) bignum-ptr)) (hw:read-md)))) (if (hw:32zerop (hw:32+ high-word (hw:ldb next-word (byte 1. 31.) (hw:unboxed-constant 0)))) (progn (hw:write-md-unboxed (hw:unboxed-constant 0)) (hw:vma-start-write-no-gc-trap-unboxed (hw:32+ size bignum-ptr)) (setq size (1- size)) (setq high-word next-word) (reduce-bignum)) (values bignum-ptr (hw:dpb (hw:ldb high-word (byte 1. 31.) 0) (byte 1. 17.) 0))))))) (reduce-bignum))))