Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19438

Modified Files: integers.lisp Log Message: Extracted most compiler-macros from integers.lisp into arithmetic-macros.lisp.

Date: Sat Jul 17 05:16:12 2004 Author: ffjeld

Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.70 movitz/losp/muerte/integers.lisp:1.71 --- movitz/losp/muerte/integers.lisp:1.70 Sat Jul 17 04:27:58 2004 +++ movitz/losp/muerte/integers.lisp Sat Jul 17 05:16:12 2004 @@ -9,12 +9,13 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.70 2004/07/17 11:27:58 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.71 2004/07/17 12:16:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

(require :muerte/basic-macros) (require :muerte/typep) +(require :muerte/arithmetic-macros) (provide :muerte/integers)

(in-package muerte) @@ -22,113 +23,404 @@ (defconstant most-positive-fixnum #.movitz::+movitz-most-positive-fixnum+) (defconstant most-negative-fixnum #.movitz::+movitz-most-negative-fixnum+)

-(deftype positive-fixnum () - `(integer 0 ,movitz:+movitz-most-positive-fixnum+)) - -(deftype positive-bignum () - `(integer ,(1+ movitz:+movitz-most-positive-fixnum+) *)) - -(deftype negative-fixnum () - `(integer ,movitz:+movitz-most-negative-fixnum+ -1))

-(defmacro number-double-dispatch ((x y) &rest clauses) - `(let ((x ,x) (y ,y)) - (cond ,@(loop for ((x-type y-type) . then-body) in clauses - collect `((and (typep x ',x-type) (typep y ',y-type)) - ,@then-body)) - (t (error "Not numbers: ~S or ~S." x y))))) - -(defun fixnump (x) - (typep x 'fixnum)) +;;; Comparison

-(define-compiler-macro evenp (x) - `(with-inline-assembly (:returns :boolean-zf=1) - (:compile-form (:result-mode :eax) ,x) - (:call-global-pf unbox-u32) - (:testb 1 :cl))) +(define-primitive-function fast-compare-two-reals (n1 n2) + "Compare two numbers (i.e. set EFLAGS accordingly)." + (macrolet + ((do-it () + `(with-inline-assembly (:returns :nothing) ; unspecified + (:testb ,movitz::+movitz-fixnum-zmask+ :al) + (:jnz 'n1-not-fixnum) + (:testb ,movitz::+movitz-fixnum-zmask+ :bl) + (:jnz 'n2-not-fixnum-but-n1-is) + (:cmpl :ebx :eax) ; both were fixnum + (:ret) + n1-not-fixnum ; but we don't know about n2 + (:testb ,movitz::+movitz-fixnum-zmask+ :bl) + (:jnz 'neither-is-fixnum) + ;; n2 is fixnum + (:locally (:jmp (:edi (:edi-offset fast-compare-real-fixnum)))) + n2-not-fixnum-but-n1-is + (:locally (:jmp (:edi (:edi-offset fast-compare-fixnum-real)))) + neither-is-fixnum + ;; Check that both numbers are bignums, and compare them. + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program (n1-not-bignum) + (:int 107))) + (:movl (:eax ,movitz:+other-type-offset+) :ecx) + (:cmpb ,(movitz:tag :bignum) :cl) + (:jne 'n1-not-bignum)

-(defun evenp (x) - (evenp x)) + (:cmpl :eax :ebx) ; If they are EQ, they are certainly = + (:je '(:sub-program (n1-and-n2-are-eq) + (:ret)))

-(define-compiler-macro oddp (x) - `(with-inline-assembly (:returns :boolean-zf=0) - (:compile-form (:result-mode :eax) ,x) - (:call-global-pf unbox-u32) - (:testb 1 :cl))) + (:leal (:ebx ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program (n2-not-bignum) + (:int 107))) + (:movl (:ebx ,movitz:+other-type-offset+) :ecx) + (:cmpb ,(movitz:tag :bignum) :cl) + (:jne 'n2-not-bignum)

-(defun oddp (x) - (oddp x)) + (:cmpb :ch (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::sign))) + (:jne '(:sub-program (different-signs) + ;; Comparing the sign-bytes sets up EFLAGS correctly! + (:ret))) + (:testl #xff00 :ecx) + (:jnz 'compare-negatives) + ;; Both n1 and n2 are positive bignums.

-;;; Types + (:shrl 16 :ecx) + (:cmpw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length))) + (:jne '(:sub-program (positive-different-sizes) + (:ret)))

-(define-typep integer (x &optional (min '*) (max '*)) - (and (typep x 'integer) - (or (eq min '*) (<= min x)) - (or (eq max '*) (<= x max)))) + ;; Both n1 and n2 are positive bignums of the same size, namely ECX. + (:movl :ecx :edx) ; counter + positive-compare-loop + (:subl ,movitz:+movitz-fixnum-factor+ :edx) + (:jz 'positive-compare-lsb) + (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) + (:cmpl :ecx + (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:je 'positive-compare-loop) + positive-compare-lsb + ;; Now we have to make the compare act as unsigned, which is why + ;; we compare zero-extended 16-bit quantities. + (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + :ecx) ; First compare upper 16 bits. + (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:movzxw (:eax :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + :ecx) + (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx)) + (:jne 'upper-16-decisive) + (:movzxw (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) ; Then compare lower 16 bits. + (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:movzxw (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) ; Then compare lower 16 bits. + (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx)) + upper-16-decisive + (:ret) + + compare-negatives + ;; Moth n1 and n2 are negative bignums.

-(deftype signed-byte (&optional (size '*)) - (cond - ((eq size '*) - 'integer) - ((typep size '(integer 1 *)) - (list 'integer - (- (ash 1 (1- size))) - (1- (ash 1 (1- size))))) - (t (error "Illegal size for signed-byte.")))) + (:shrl 16 :ecx) + (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)) :cx) + (:jne '(:sub-program (negative-different-sizes) + (:ret)))

-(deftype unsigned-byte (&optional (size '*)) - (cond - ((eq size '*) - '(integer 0)) - ((typep size '(integer 1 *)) - (list 'integer 0 (1- (ash 1 size)))) - (t (error "Illegal size for unsigned-byte.")))) + ;; Both n1 and n2 are negative bignums of the same size, namely ECX. + (:movl :ecx :edx) ; counter + negative-compare-loop + (:subl ,movitz:+movitz-fixnum-factor+ :edx) + (:jz 'negative-compare-lsb) + (:movl (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) + (:cmpl :ecx + (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:je 'negative-compare-loop) + (:ret) + negative-compare-lsb ; it's down to the LSB bigits. + ;; Now we have to make the compare act as unsigned, which is why + ;; we compare zero-extended 16-bit quantities. + (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + :ecx) ; First compare upper 16 bits. + (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:movzxw (:eax :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + :ecx) + (:locally (:cmpl :ecx (:edi (:edi-offset scratch0)))) + (:jne 'negative-upper-16-decisive) + (:movzxw (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) ; Then compare lower 16 bits. + (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:movzxw (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) ; Then compare lower 16 bits. + (:locally (:cmpl :ecx (:edi (:edi-offset scratch0)))) + negative-upper-16-decisive + (:ret)))) + (do-it)))

-(define-simple-typep (bit bitp) (x) - (or (eq x 0) (eq x 1))) +(define-primitive-function fast-eql (x y) + "Compare EAX and EBX under EQL, result in ZF. +Preserve EAX and EBX." + (macrolet + ((do-it () + `(with-inline-assembly (:returns :nothing) ; unspecified + (:cmpl :eax :ebx) ; EQ? + (:je 'done) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jne 'done) + (:leal (:ebx ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jne 'done) + (:movl (:eax ,movitz:+other-type-offset+) :ecx) + (:cmpb ,(movitz:tag :bignum) :cl) + (:jne 'done) + (:cmpl :ecx (:ebx ,movitz:+other-type-offset+)) + (:jne 'done) + ;; Ok.. we have two bignums of identical sign and size. + (:shrl 16 :ecx) + (:movl :ecx :edx) ; counter + compare-loop + (:subl ,movitz:+movitz-fixnum-factor+ :edx) + (:jz 'done) + (:movl (:eax :edx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + :ecx) + (:cmpl :ecx + (:ebx :edx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))) + (:je 'compare-loop) + done + (:ret)))) + (do-it)))

-;;; +(define-primitive-function fast-compare-fixnum-real (n1 n2) + "Compare (known) fixnum <n1> with real <n2>." + (macrolet + ((do-it () + `(with-inline-assembly (:returns :nothing) ; unspecified + (:testb ,movitz::+movitz-fixnum-zmask+ :bl) + (:jnz 'n2-not-fixnum) + (:cmpl :ebx :eax) + (:ret) + n2-not-fixnum + (:leal (:ebx ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program (not-integer) + (:int 107) + (:jmp 'not-integer))) + (:movl (:ebx ,movitz:+other-type-offset+) :ecx) + (:cmpw ,(movitz:tag :bignum 0) :cx) + (:jne 'not-plusbignum) + ;; compare eax with something bigger + (:cmpl #x10000000 :edi) + (:ret) + not-plusbignum + (:cmpw ,(movitz:tag :bignum #xff) :cx) + (:jne 'not-integer) + ;; compare ebx with something bigger + (:cmpl #x-10000000 :edi) + (:ret)))) + (do-it)))

-(defun %negatef (x p0 p1) - "Negate x. If x is not eq to p0 or p1, negate x destructively." - (etypecase x - (fixnum (- x)) - (bignum - (if (or (eq x p0) (eq x p1)) - (- x) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:xorl #xff00 (:eax #.movitz:+other-type-offset+))))))) +(define-primitive-function fast-compare-real-fixnum (n1 n2) + "Compare real <n1> with fixnum <n2>." + (with-inline-assembly (:returns :nothing) ; unspecified + (:testb #.movitz::+movitz-fixnum-zmask+ :al) + (:jnz 'not-fixnum) + (:cmpl :ebx :eax) + (:ret) + not-fixnum + (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program (not-integer) + (:int 107) + (:jmp 'not-integer))) + (:movl (:eax #.movitz:+other-type-offset+) :ecx) + (:cmpw #.(movitz:tag :bignum 0) :cx) + (:jne 'not-plusbignum) + ;; compare ebx with something bigger + (:cmpl #x-10000000 :edi) + (:ret) + not-plusbignum + (:cmpw #.(movitz:tag :bignum #xff) :cx) + (:jne 'not-integer) + ;; compare ebx with something bigger + (:cmpl #x10000000 :edi) + (:ret)))

-;;; Addition +;;;

-(define-compiler-macro + (&whole form &rest operands &environment env) - (case (length operands) - (0 0) - (1 (first operands)) - #+ignore (2 `(+%2op ,(first operands) ,(second operands))) - (2 `(let ((x ,(first operands)) - (y ,(second operands))) - (++%2op x y))) - (t (let ((operands - (loop for operand in operands - if (movitz:movitz-constantp operand env) - sum (movitz:movitz-eval operand env) - into constant-term - else collect operand - into non-constant-operands - finally (return (if (zerop constant-term) - non-constant-operands - (cons constant-term non-constant-operands)))))) - `(+ (+ ,(first operands) ,(second operands)) ,@(cddr operands))))))

-(defun + (&rest terms) - (declare (without-check-stack-limit)) - (numargs-case - (1 (x) x) - (2 (x y) - (macrolet - ((do-it () +(defmacro define-number-relational (name 2op-name condition &key (defun-p t) 3op-name) + `(progn + ,(when condition + `(define-compiler-macro ,2op-name (n1 n2) + (cond + ((movitz:movitz-constantp n1) + (let ((n1 (movitz::movitz-eval n1))) + (check-type n1 (signed-byte 30)) + `(with-inline-assembly (:returns ,,condition :side-effects nil) + (:compile-two-forms (:eax :ebx) ,n1 ,n2) + (:call-global-pf fast-compare-fixnum-real)))) + ((movitz:movitz-constantp n2) + (let ((n2 (movitz::movitz-eval n2))) + (check-type n2 (signed-byte 30)) + `(with-inline-assembly (:returns ,,condition :side-effects nil) + (:compile-two-forms (:eax :ebx) ,n1 ,n2) + (:call-global-pf fast-compare-real-fixnum)))) + (t `(with-inline-assembly (:returns ,,condition :side-effects nil) + (:compile-two-forms (:eax :ebx) ,n1 ,n2) + (:call-global-pf fast-compare-two-reals)))))) + + (defun ,2op-name (n1 n2) + (,2op-name n1 n2)) + + (define-compiler-macro ,name (&whole form number &rest more-numbers) + (case (length more-numbers) + (0 `(progn ,number t)) + (1 `(,',2op-name ,number ,(first more-numbers))) + ,@(when 3op-name + `((2 `(,',3op-name ,number ,(first more-numbers) ,(second more-numbers))))) + (t #+ignore (when (= 2 (length more-numbers)) + (warn "3op: ~S" form)) + `(and (,',2op-name ,number ,(first more-numbers)) + (,',name ,@more-numbers))))) + + ,(when defun-p + `(defun ,name (number &rest more-numbers) + (declare (dynamic-extent more-numbers)) + (cond + ((null more-numbers) + (check-type number fixnum) + t) + ((not (cdr more-numbers)) + (,2op-name number (first more-numbers))) + (t (and (,2op-name number (first more-numbers)) + (do ((p more-numbers (cdr p))) + ((not (cdr p)) t) + (unless (,2op-name (car p) (cadr p)) + (return nil)))))))))) + +(define-number-relational >= >=%2op :boolean-greater-equal) +(define-number-relational > >%2op :boolean-greater) +(define-number-relational < <%2op :boolean-less) +(define-number-relational <= <=%2op :boolean-less-equal :3op-name <=%3op) + +;;; Unsigned + +(defun below (x max) + "Is x between 0 and max?" + (compiler-macro-call below x max)) + + +;;; Equality + +(define-compiler-macro =%2op (n1 n2 &environment env) + (cond + ((movitz:movitz-constantp n1 env) + (let ((n1 (movitz:movitz-eval n1 env))) + (etypecase n1 + ((eql 0) + `(do-result-mode-case () + (:booleans + (with-inline-assembly (:returns :boolean-zf=1 :side-effects nil) + (:compile-form (:result-mode :eax) ,n2) + (:testl :eax :eax))) + (t (with-inline-assembly (:returns :boolean-cf=1 :side-effects nil) + (:compile-form (:result-mode :eax) ,n2) + (:cmpl 1 :eax))))) + ((signed-byte 30) + `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil) + (:compile-two-forms (:eax :ebx) ,n1 ,n2) + (:call-global-pf fast-compare-fixnum-real))) + (integer + `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil) + (:compile-two-forms (:eax :ebx) ,n1 ,n2) + (:call-global-pf fast-compare-two-reals)))))) + ((movitz:movitz-constantp n2 env) + `(=%2op ,n2 ,n1)) + (t `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil) + (:compile-two-forms (:eax :ebx) ,n1 ,n2) + (:call-global-pf fast-compare-two-reals))))) + +(define-number-relational = =%2op nil :defun-p nil) + +(defun = (first-number &rest numbers) + (declare (dynamic-extent numbers)) + (dolist (n numbers t) + (unless (= first-number n) + (return nil)))) + +(define-number-relational /= /=%2op :boolean-zf=0 :defun-p nil) + +(defun /= (&rest numbers) + (declare (dynamic-extent numbers)) + (do ((p (cdr numbers) (cdr p))) + ((null p) t) + (do ((v numbers (cdr v))) + ((eq p v)) + (when (= (car p) (car v)) + (return-from /= nil))))) + + +;;;; + +(deftype positive-fixnum () + `(integer 0 ,movitz:+movitz-most-positive-fixnum+)) + +(deftype positive-bignum () + `(integer ,(1+ movitz:+movitz-most-positive-fixnum+) *)) + +(deftype negative-fixnum () + `(integer ,movitz:+movitz-most-negative-fixnum+ -1)) + +(defun fixnump (x) + (typep x 'fixnum)) + +(defun evenp (x) + (compiler-macro-call evenp x)) + +(defun oddp (x) + (compiler-macro-call oddp x)) + +;;; Types + +(define-typep integer (x &optional (min '*) (max '*)) + (and (typep x 'integer) + (or (eq min '*) (<= min x)) + (or (eq max '*) (<= x max)))) + +(deftype signed-byte (&optional (size '*)) + (cond + ((eq size '*) + 'integer) + ((typep size '(integer 1 *)) + (list 'integer + (- (ash 1 (1- size))) + (1- (ash 1 (1- size))))) + (t (error "Illegal size for signed-byte.")))) + +(deftype unsigned-byte (&optional (size '*)) + (cond + ((eq size '*) + '(integer 0)) + ((typep size '(integer 1 *)) + (list 'integer 0 (1- (ash 1 size)))) + (t (error "Illegal size for unsigned-byte.")))) + +(define-simple-typep (bit bitp) (x) + (or (eq x 0) (eq x 1))) + +;;; + +(defun %negatef (x p0 p1) + "Negate x. If x is not eq to p0 or p1, negate x destructively." + (etypecase x + (fixnum (- x)) + (bignum + (if (or (eq x p0) (eq x p1)) + (- x) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:xorl #xff00 (:eax #.movitz:+other-type-offset+))))))) + +;;; Addition + +(defun + (&rest terms) + (declare (without-check-stack-limit)) + (numargs-case + (1 (x) x) + (2 (x y) + (macrolet + ((do-it () `(number-double-dispatch (x y) ((fixnum fixnum) (with-inline-assembly (:returns :eax) @@ -315,677 +607,214 @@ retry-not-size1 (:compile-form (:result-mode :eax) y) (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) - not-size1 - (:declare-label-set retry-jumper (retry-not-size1)) - (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) - (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) - 'retry-jumper) - (:edi (:edi-offset atomically-status)))) - (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+)) - :eax) ; Number of words - (:call-local-pf get-cons-pointer) - (:load-lexical (:lexical-binding y) :ebx) ; bignum - (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) - (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+) - :edx) - (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB - copy-bignum-loop - (:subl ,movitz:+movitz-fixnum-factor+ :edx) - (:movl (:ebx :edx ,movitz:+other-type-offset+) :ecx) - (:movl :ecx (:eax :edx ,movitz:+other-type-offset+)) - (:jnz 'copy-bignum-loop) - - (:load-lexical (:lexical-binding x) :ebx) - (:xorl :edx :edx) ; counter - (:xorl :ecx :ecx) ; Carry - add-bignum-loop - (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) - (:jbe '(:sub-program (zero-padding-loop) - (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum - 'movitz::bigit0))) - (:sbbl :ecx :ecx) - (:negl :ecx) ; ECX = Add's Carry. - (:addl 4 :edx) - (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) - (:jae 'zero-padding-loop) - (:jmp 'add-bignum-done))) - (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) - :ecx) - (:jc '(:sub-program (term1-carry) - ;; The digit + carry carried over, ECX = 0 - (:addl 1 :ecx) - (:addl 4 :edx) - (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) - (:jae 'add-bignum-loop) - (:jmp 'add-bignum-done))) - (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) - (:sbbl :ecx :ecx) - (:negl :ecx) ; ECX = Add's Carry. - (:addl 4 :edx) - (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) - (:jae 'add-bignum-loop) - add-bignum-done - (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) - :ecx) - (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+) - :ecx) - (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) - (:je 'no-expansion) - (:addl #x40000 (:eax ,movitz:+other-type-offset+)) - (:addl ,movitz:+movitz-fixnum-factor+ :ecx) - no-expansion - (:call-local-pf cons-commit) - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))) - pfix-pbig-done) - )) - (((integer * -1) (integer 0 *)) - (- y (- x))) - (((integer 0 *) (integer * -1)) - (- x (- y))) - (((integer * -1) (integer * -1)) - (%negatef (+ (- x) (- y)) x y)) - ))) - (do-it))) - (t (&rest terms) - (declare (dynamic-extent terms)) - (if (null terms) - 0 - (reduce #'+ terms))))) - -(defun 1+ (number) - (+ 1 number)) - -(define-compiler-macro 1+ (number) - `(+ 1 ,number)) - -(defun 1- (number) - (+ -1 number)) - -(define-compiler-macro 1- (number) - `(+ -1 ,number)) - -(define-modify-macro incf (&optional (delta-form 1)) +) - -;;; Subtraction - -(define-compiler-macro - (&whole form &rest operands &environment env) - (case (length operands) - (0 0) - (1 (let ((x (first operands))) - (if (movitz:movitz-constantp x env) - (- (movitz:movitz-eval x env)) - form))) - (2 (let ((minuend (first operands)) - (subtrahend (second operands))) - (cond - ((movitz:movitz-constantp subtrahend env) - `(+ ,minuend ,(- (movitz:movitz-eval subtrahend env)))) - (t form)))) - (t `(- ,(first operands) (+ ,@(rest operands)))))) - -(defun - (minuend &rest subtrahends) - (declare (dynamic-extent subtrahends)) - (numargs-case - (1 (x) - (macrolet - ((do-it () - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:testb ,movitz:+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program (not-fixnum) - (:leal (:eax ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jnz '(:sub-program (not-a-number) - (:compile-form (:result-mode :ignore) - (error 'type-error :expected-type 'number :datum x)))) - (:movl (:eax ,movitz:+other-type-offset+) :ecx) - (:cmpb ,(movitz:tag :bignum) :cl) - (:jne 'not-a-number) - (:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0)) :ecx) - (:jne 'not-most-negative-fixnum) - (:cmpl ,(- most-negative-fixnum) - (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) - (:jne 'not-most-negative-fixnum) - (:movl ,(ldb (byte 32 0) - (* most-negative-fixnum movitz::+movitz-fixnum-factor+)) - :eax) - (:jmp 'fix-ok) - not-most-negative-fixnum - (:compile-form (:result-mode :eax) - (copy-bignum x)) - (:notb (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign))) - (:jmp 'fix-ok))) - (:negl :eax) - (:jo '(:sub-program (fix-overflow) - (:compile-form (:result-mode :eax) - ,(1+ movitz:+movitz-most-positive-fixnum+)) - (:jmp 'fix-ok))) - fix-ok - ))) - (do-it))) - (2 (minuend subtrahend) - (macrolet - ((do-it () - `(number-double-dispatch (minuend subtrahend) - ((t (eql 0)) - minuend) - (((eql 0) t) - (- subtrahend)) - ((fixnum fixnum) - (with-inline-assembly (:returns :eax :side-effects nil) - (:compile-two-forms (:eax :ebx) minuend subtrahend) - (:subl :ebx :eax) - (:into))) - ((positive-bignum fixnum) - (+ (- subtrahend) minuend)) - ((fixnum positive-bignum) - (- (+ (- minuend) subtrahend))) - ((positive-bignum positive-bignum) - (cond - ((= minuend subtrahend) - 0) - ((< minuend subtrahend) - (let ((x (- subtrahend minuend))) - (%negatef x subtrahend minuend))) - (t (%bignum-canonicalize - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) (copy-bignum minuend) subtrahend) - (:xorl :edx :edx) ; counter - (:xorl :ecx :ecx) ; carry - sub-loop - (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) - :ecx) - (:jc '(:sub-program (carry-overflow) - ;; Just propagate carry - (:addl 1 :ecx) - (:addl 4 :edx) - (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) - (:jne 'sub-loop) - (:jmp 'bignum-sub-done))) - (:subl :ecx - (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) - (:sbbl :ecx :ecx) - (:negl :ecx) - (:addl 4 :edx) - (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) - (:jne 'sub-loop) - (:subl :ecx - (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) - (:jnc 'bignum-sub-done) - propagate-carry - (:addl 4 :edx) - (:subl 1 (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) - (:jc 'propagate-carry) - bignum-sub-done - ))))) - (((integer 0 *) (integer * -1)) - (+ minuend (- subtrahend))) - (((integer * -1) (integer 0 *)) - (%negatef (+ (- minuend) subtrahend) minuend subtrahend)) - (((integer * -1) (integer * -1)) - (+ minuend (- subtrahend))) - ))) - (do-it))) - (t (minuend &rest subtrahends) - (declare (dynamic-extent subtrahends)) - (if subtrahends - (reduce #'- subtrahends :initial-value minuend) - (- minuend))))) - -(define-modify-macro decf (&optional (delta-form 1)) -) - -;;; Comparison - -(define-primitive-function fast-compare-two-reals (n1 n2) - "Compare two numbers (i.e. set EFLAGS accordingly)." - (macrolet - ((do-it () - `(with-inline-assembly (:returns :nothing) ; unspecified - (:testb ,movitz::+movitz-fixnum-zmask+ :al) - (:jnz 'n1-not-fixnum) - (:testb ,movitz::+movitz-fixnum-zmask+ :bl) - (:jnz 'n2-not-fixnum-but-n1-is) - (:cmpl :ebx :eax) ; both were fixnum - (:ret) - n1-not-fixnum ; but we don't know about n2 - (:testb ,movitz::+movitz-fixnum-zmask+ :bl) - (:jnz 'neither-is-fixnum) - ;; n2 is fixnum - (:locally (:jmp (:edi (:edi-offset fast-compare-real-fixnum)))) - n2-not-fixnum-but-n1-is - (:locally (:jmp (:edi (:edi-offset fast-compare-fixnum-real)))) - neither-is-fixnum - ;; Check that both numbers are bignums, and compare them. - (:leal (:eax ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jnz '(:sub-program (n1-not-bignum) - (:int 107))) - (:movl (:eax ,movitz:+other-type-offset+) :ecx) - (:cmpb ,(movitz:tag :bignum) :cl) - (:jne 'n1-not-bignum) - - (:cmpl :eax :ebx) ; If they are EQ, they are certainly = - (:je '(:sub-program (n1-and-n2-are-eq) - (:ret))) - - (:leal (:ebx ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jnz '(:sub-program (n2-not-bignum) - (:int 107))) - (:movl (:ebx ,movitz:+other-type-offset+) :ecx) - (:cmpb ,(movitz:tag :bignum) :cl) - (:jne 'n2-not-bignum) - - (:cmpb :ch (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::sign))) - (:jne '(:sub-program (different-signs) - ;; Comparing the sign-bytes sets up EFLAGS correctly! - (:ret))) - (:testl #xff00 :ecx) - (:jnz 'compare-negatives) - ;; Both n1 and n2 are positive bignums. - - (:shrl 16 :ecx) - (:cmpw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length))) - (:jne '(:sub-program (positive-different-sizes) - (:ret))) - - ;; Both n1 and n2 are positive bignums of the same size, namely ECX. - (:movl :ecx :edx) ; counter - positive-compare-loop - (:subl ,movitz:+movitz-fixnum-factor+ :edx) - (:jz 'positive-compare-lsb) - (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) - :ecx) - (:cmpl :ecx - (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) - (:je 'positive-compare-loop) - positive-compare-lsb - ;; Now we have to make the compare act as unsigned, which is why - ;; we compare zero-extended 16-bit quantities. - (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) - :ecx) ; First compare upper 16 bits. - (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) - (:movzxw (:eax :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) - :ecx) - (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx)) - (:jne 'upper-16-decisive) - (:movzxw (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) - :ecx) ; Then compare lower 16 bits. - (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) - (:movzxw (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) - :ecx) ; Then compare lower 16 bits. - (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx)) - upper-16-decisive - (:ret) - - compare-negatives - ;; Moth n1 and n2 are negative bignums. - - (:shrl 16 :ecx) - (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)) :cx) - (:jne '(:sub-program (negative-different-sizes) - (:ret))) - - ;; Both n1 and n2 are negative bignums of the same size, namely ECX. - (:movl :ecx :edx) ; counter - negative-compare-loop - (:subl ,movitz:+movitz-fixnum-factor+ :edx) - (:jz 'negative-compare-lsb) - (:movl (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) - :ecx) - (:cmpl :ecx - (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) - (:je 'negative-compare-loop) - (:ret) - negative-compare-lsb ; it's down to the LSB bigits. - ;; Now we have to make the compare act as unsigned, which is why - ;; we compare zero-extended 16-bit quantities. - (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) - :ecx) ; First compare upper 16 bits. - (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) - (:movzxw (:eax :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) - :ecx) - (:locally (:cmpl :ecx (:edi (:edi-offset scratch0)))) - (:jne 'negative-upper-16-decisive) - (:movzxw (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) - :ecx) ; Then compare lower 16 bits. - (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) - (:movzxw (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) - :ecx) ; Then compare lower 16 bits. - (:locally (:cmpl :ecx (:edi (:edi-offset scratch0)))) - negative-upper-16-decisive - (:ret)))) - (do-it))) - -(define-primitive-function fast-eql (x y) - "Compare EAX and EBX under EQL, result in ZF. -Preserve EAX and EBX." - (macrolet - ((do-it () - `(with-inline-assembly (:returns :nothing) ; unspecified - (:cmpl :eax :ebx) ; EQ? - (:je 'done) - (:leal (:eax ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jne 'done) - (:leal (:ebx ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jne 'done) - (:movl (:eax ,movitz:+other-type-offset+) :ecx) - (:cmpb ,(movitz:tag :bignum) :cl) - (:jne 'done) - (:cmpl :ecx (:ebx ,movitz:+other-type-offset+)) - (:jne 'done) - ;; Ok.. we have two bignums of identical sign and size. - (:shrl 16 :ecx) - (:movl :ecx :edx) ; counter - compare-loop - (:subl ,movitz:+movitz-fixnum-factor+ :edx) - (:jz 'done) - (:movl (:eax :edx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) - :ecx) - (:cmpl :ecx - (:ebx :edx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))) - (:je 'compare-loop) - done - (:ret)))) - (do-it))) - -(define-primitive-function fast-compare-fixnum-real (n1 n2) - "Compare (known) fixnum <n1> with real <n2>." - (macrolet - ((do-it () - `(with-inline-assembly (:returns :nothing) ; unspecified - (:testb ,movitz::+movitz-fixnum-zmask+ :bl) - (:jnz 'n2-not-fixnum) - (:cmpl :ebx :eax) - (:ret) - n2-not-fixnum - (:leal (:ebx ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jnz '(:sub-program (not-integer) - (:int 107) - (:jmp 'not-integer))) - (:movl (:ebx ,movitz:+other-type-offset+) :ecx) - (:cmpw ,(movitz:tag :bignum 0) :cx) - (:jne 'not-plusbignum) - ;; compare eax with something bigger - (:cmpl #x10000000 :edi) - (:ret) - not-plusbignum - (:cmpw ,(movitz:tag :bignum #xff) :cx) - (:jne 'not-integer) - ;; compare ebx with something bigger - (:cmpl #x-10000000 :edi) - (:ret)))) - (do-it))) - -(define-primitive-function fast-compare-real-fixnum (n1 n2) - "Compare real <n1> with fixnum <n2>." - (with-inline-assembly (:returns :nothing) ; unspecified - (:testb #.movitz::+movitz-fixnum-zmask+ :al) - (:jnz 'not-fixnum) - (:cmpl :ebx :eax) - (:ret) - not-fixnum - (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jnz '(:sub-program (not-integer) - (:int 107) - (:jmp 'not-integer))) - (:movl (:eax #.movitz:+other-type-offset+) :ecx) - (:cmpw #.(movitz:tag :bignum 0) :cx) - (:jne 'not-plusbignum) - ;; compare ebx with something bigger - (:cmpl #x-10000000 :edi) - (:ret) - not-plusbignum - (:cmpw #.(movitz:tag :bignum #xff) :cx) - (:jne 'not-integer) - ;; compare ebx with something bigger - (:cmpl #x10000000 :edi) - (:ret))) - -;;; - -(define-compiler-macro <=%3op (min x max &environment env) - (cond - ((and (movitz:movitz-constantp min env) - (movitz:movitz-constantp max env)) - (let ((min (movitz:movitz-eval min env)) - (max (movitz:movitz-eval max env))) - (check-type min fixnum) - (check-type max fixnum) - ;; (warn "~D -- ~D" min max) - (cond - ((movitz:movitz-constantp x env) - (<= min (movitz:movitz-eval x env) max)) - ((< max min) - nil) - ((= max min) - `(= ,x ,min)) - ((minusp min) - `(let ((x ,x)) - (and (<= ,min x) (<= x ,max)))) - ((= 0 min) - `(with-inline-assembly (:returns :boolean-cf=1) - (:compile-form (:result-mode :eax) ,x) - (:testb ,movitz::+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program () (:int 107))) - (:cmpl ,(* (1+ max) movitz::+movitz-fixnum-factor+) :eax))) - (t `(do-result-mode-case () - (:booleans - (with-inline-assembly (:returns :boolean-zf=0) - (:compile-form (:result-mode :eax) ,x) - (:testb ,movitz::+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program () (:int 107))) - (:cmpl ,(* min movitz::+movitz-fixnum-factor+) :eax) - (:sbbl :ecx :ecx) - (:cmpl ,(* (1+ max) movitz::+movitz-fixnum-factor+) :eax) - (:adcl 0 :ecx))) - (t (with-inline-assembly (:returns (:boolean-ecx 1 0)) - (:compile-form (:result-mode :eax) ,x) - (:testb ,movitz::+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program () (:int 107))) - (:cmpl ,(* min movitz::+movitz-fixnum-factor+) :eax) - (:sbbl :ecx :ecx) - (:cmpl ,(* (1+ max) movitz::+movitz-fixnum-factor+) :eax) - (:adcl 0 :ecx)))))))) - #+ignore ; this is buggy. - ((movitz:movitz-constantp min env) - (let ((min (movitz:movitz-eval min env))) - (check-type min fixnum) - (cond - ((minusp min) - `(let ((x ,x)) - (and (<= ,min x) (<= x ,max)))) - (t `(do-result-mode-case () - (:booleans - (with-inline-assembly (:returns :boolean-zf=1) - (:compile-two-forms (:eax :ebx) ,x ,max) - (:movl :eax :ecx) - (:orl :ebx :ecx) - (:testb ,movitz::+movitz-fixnum-zmask+ :cl) - (:jne '(:sub-program () (:int 107))) - (:cmpl :eax :ebx) - (:sbbl :ecx :ecx) - ,@(unless (= 0 min) - `((:subl ,(* min movitz::+movitz-fixnum-factor+) :ebx))) - (:addl :ebx :ebx) - (:adcl 0 :ecx))) - (t (with-inline-assembly (:returns (:boolean-ecx 0 1)) - (:compile-two-forms (:eax :ebx) ,x ,max) - (:movl :eax :ecx) - (:orl :ebx :ecx) - (:testb ,movitz::+movitz-fixnum-zmask+ :cl) - (:jne '(:sub-program () (:int 107))) - (:cmpl :eax :ebx) ; if x>max, CF=1 - (:sbbl :ecx :ecx) ; ecx = x>max ? -1 : 0 - ,@(unless (= 0 min) - `((:subl ,(* min movitz::+movitz-fixnum-factor+) :ebx))) - (:addl :ebx :ebx) ; if x<min, CF=1 - (:adcl 0 :ecx) ; - (:andl 1 :ecx)))))))) - (t `(let ((x ,x)) - (and (<= ,min x) (<= x ,max)))))) - - -(defmacro define-number-relational (name 2op-name condition &key (defun-p t) 3op-name) - `(progn - ,(when condition - `(define-compiler-macro ,2op-name (n1 n2) - (cond - ((movitz:movitz-constantp n1) - (let ((n1 (movitz::movitz-eval n1))) - (check-type n1 (signed-byte 30)) - `(with-inline-assembly (:returns ,,condition :side-effects nil) - (:compile-two-forms (:eax :ebx) ,n1 ,n2) - (:call-global-pf fast-compare-fixnum-real)))) - ((movitz:movitz-constantp n2) - (let ((n2 (movitz::movitz-eval n2))) - (check-type n2 (signed-byte 30)) - `(with-inline-assembly (:returns ,,condition :side-effects nil) - (:compile-two-forms (:eax :ebx) ,n1 ,n2) - (:call-global-pf fast-compare-real-fixnum)))) - (t `(with-inline-assembly (:returns ,,condition :side-effects nil) - (:compile-two-forms (:eax :ebx) ,n1 ,n2) - (:call-global-pf fast-compare-two-reals)))))) - - (defun ,2op-name (n1 n2) - (,2op-name n1 n2)) - - (define-compiler-macro ,name (&whole form number &rest more-numbers) - (case (length more-numbers) - (0 `(progn ,number t)) - (1 `(,',2op-name ,number ,(first more-numbers))) - ,@(when 3op-name - `((2 `(,',3op-name ,number ,(first more-numbers) ,(second more-numbers))))) - (t #+ignore (when (= 2 (length more-numbers)) - (warn "3op: ~S" form)) - `(and (,',2op-name ,number ,(first more-numbers)) - (,',name ,@more-numbers))))) - - ,(when defun-p - `(defun ,name (number &rest more-numbers) - (declare (dynamic-extent more-numbers)) - (cond - ((null more-numbers) - (check-type number fixnum) - t) - ((not (cdr more-numbers)) - (,2op-name number (first more-numbers))) - (t (and (,2op-name number (first more-numbers)) - (do ((p more-numbers (cdr p))) - ((not (cdr p)) t) - (unless (,2op-name (car p) (cadr p)) - (return nil)))))))))) - -(define-number-relational >= >=%2op :boolean-greater-equal) -(define-number-relational > >%2op :boolean-greater) -(define-number-relational < <%2op :boolean-less) -(define-number-relational <= <=%2op :boolean-less-equal :3op-name <=%3op) - -;;; Unsigned - -(define-compiler-macro below (&whole form x max &environment env) - (let ((below-not-integer (gensym "below-not-integer-"))) - (if (movitz:movitz-constantp max env) - `(with-inline-assembly (:returns :boolean-cf=1) - (:compile-form (:result-mode :eax) ,x) - (:testb ,movitz::+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program (,below-not-integer) (:int 107))) - (:cmpl ,(* (movitz:movitz-eval max env) - movitz::+movitz-fixnum-factor+) - :eax)) - `(with-inline-assembly (:returns :boolean-cf=1) - (:compile-two-forms (:eax :ebx) ,x ,max) - (:movl :eax :ecx) - (:orl :ebx :ecx) - (:testb ,movitz::+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program (,below-not-integer) (:int 107))) - (:cmpl :ebx :eax))))) - -(defun below (x max) - "Is x between 0 and max?" - (below x max)) - - -;;; Equality + not-size1 + (:declare-label-set retry-jumper (retry-not-size1)) + (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+)) + :eax) ; Number of words + (:call-local-pf get-cons-pointer) + (:load-lexical (:lexical-binding y) :ebx) ; bignum + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) + (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+) + :edx) + (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB + copy-bignum-loop + (:subl ,movitz:+movitz-fixnum-factor+ :edx) + (:movl (:ebx :edx ,movitz:+other-type-offset+) :ecx) + (:movl :ecx (:eax :edx ,movitz:+other-type-offset+)) + (:jnz 'copy-bignum-loop)

-(define-compiler-macro =%2op (n1 n2 &environment env) - (cond - ((movitz:movitz-constantp n1 env) - (let ((n1 (movitz:movitz-eval n1 env))) - (etypecase n1 - ((eql 0) - `(do-result-mode-case () - (:booleans - (with-inline-assembly (:returns :boolean-zf=1 :side-effects nil) - (:compile-form (:result-mode :eax) ,n2) - (:testl :eax :eax))) - (t (with-inline-assembly (:returns :boolean-cf=1 :side-effects nil) - (:compile-form (:result-mode :eax) ,n2) - (:cmpl 1 :eax))))) - ((signed-byte 30) - `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil) - (:compile-two-forms (:eax :ebx) ,n1 ,n2) - (:call-global-pf fast-compare-fixnum-real))) - (integer - `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil) - (:compile-two-forms (:eax :ebx) ,n1 ,n2) - (:call-global-pf fast-compare-two-reals)))))) - ((movitz:movitz-constantp n2 env) - `(=%2op ,n2 ,n1)) - (t `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil) - (:compile-two-forms (:eax :ebx) ,n1 ,n2) - (:call-global-pf fast-compare-two-reals))))) + (:load-lexical (:lexical-binding x) :ebx) + (:xorl :edx :edx) ; counter + (:xorl :ecx :ecx) ; Carry + add-bignum-loop + (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jbe '(:sub-program (zero-padding-loop) + (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum + 'movitz::bigit0))) + (:sbbl :ecx :ecx) + (:negl :ecx) ; ECX = Add's Carry. + (:addl 4 :edx) + (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jae 'zero-padding-loop) + (:jmp 'add-bignum-done))) + (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) + :ecx) + (:jc '(:sub-program (term1-carry) + ;; The digit + carry carried over, ECX = 0 + (:addl 1 :ecx) + (:addl 4 :edx) + (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jae 'add-bignum-loop) + (:jmp 'add-bignum-done))) + (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:sbbl :ecx :ecx) + (:negl :ecx) ; ECX = Add's Carry. + (:addl 4 :edx) + (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jae 'add-bignum-loop) + add-bignum-done + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+) + :ecx) + (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) + (:je 'no-expansion) + (:addl #x40000 (:eax ,movitz:+other-type-offset+)) + (:addl ,movitz:+movitz-fixnum-factor+ :ecx) + no-expansion + (:call-local-pf cons-commit) + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) + pfix-pbig-done) + )) + (((integer * -1) (integer 0 *)) + (- y (- x))) + (((integer 0 *) (integer * -1)) + (- x (- y))) + (((integer * -1) (integer * -1)) + (%negatef (+ (- x) (- y)) x y)) + ))) + (do-it))) + (t (&rest terms) + (declare (dynamic-extent terms)) + (if (null terms) + 0 + (reduce #'+ terms)))))

-(define-number-relational = =%2op nil :defun-p nil) +(defun 1+ (number) + (+ 1 number))

-(defun = (first-number &rest numbers) - (declare (dynamic-extent numbers)) - (dolist (n numbers t) - (unless (= first-number n) - (return nil)))) +(defun 1- (number) + (+ -1 number))

-(define-number-relational /= /=%2op :boolean-zf=0 :defun-p nil) +;;; Subtraction

-(defun /= (&rest numbers) - (declare (dynamic-extent numbers)) - (do ((p (cdr numbers) (cdr p))) - ((null p) t) - (do ((v numbers (cdr v))) - ((eq p v)) - (when (= (car p) (car v)) - (return-from /= nil))))) +(defun - (minuend &rest subtrahends) + (declare (dynamic-extent subtrahends)) + (numargs-case + (1 (x) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) + (:jnz '(:sub-program (not-fixnum) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program (not-a-number) + (:compile-form (:result-mode :ignore) + (error 'type-error :expected-type 'number :datum x)))) + (:movl (:eax ,movitz:+other-type-offset+) :ecx) + (:cmpb ,(movitz:tag :bignum) :cl) + (:jne 'not-a-number) + (:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0)) :ecx) + (:jne 'not-most-negative-fixnum) + (:cmpl ,(- most-negative-fixnum) + (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jne 'not-most-negative-fixnum) + (:movl ,(ldb (byte 32 0) + (* most-negative-fixnum movitz::+movitz-fixnum-factor+)) + :eax) + (:jmp 'fix-ok) + not-most-negative-fixnum + (:compile-form (:result-mode :eax) + (copy-bignum x)) + (:notb (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign))) + (:jmp 'fix-ok))) + (:negl :eax) + (:jo '(:sub-program (fix-overflow) + (:compile-form (:result-mode :eax) + ,(1+ movitz:+movitz-most-positive-fixnum+)) + (:jmp 'fix-ok))) + fix-ok + ))) + (do-it))) + (2 (minuend subtrahend) + (macrolet + ((do-it () + `(number-double-dispatch (minuend subtrahend) + ((t (eql 0)) + minuend) + (((eql 0) t) + (- subtrahend)) + ((fixnum fixnum) + (with-inline-assembly (:returns :eax :side-effects nil) + (:compile-two-forms (:eax :ebx) minuend subtrahend) + (:subl :ebx :eax) + (:into))) + ((positive-bignum fixnum) + (+ (- subtrahend) minuend)) + ((fixnum positive-bignum) + (- (+ (- minuend) subtrahend))) + ((positive-bignum positive-bignum) + (cond + ((= minuend subtrahend) + 0) + ((< minuend subtrahend) + (let ((x (- subtrahend minuend))) + (%negatef x subtrahend minuend))) + (t (%bignum-canonicalize + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) (copy-bignum minuend) subtrahend) + (:xorl :edx :edx) ; counter + (:xorl :ecx :ecx) ; carry + sub-loop + (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) + :ecx) + (:jc '(:sub-program (carry-overflow) + ;; Just propagate carry + (:addl 1 :ecx) + (:addl 4 :edx) + (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jne 'sub-loop) + (:jmp 'bignum-sub-done))) + (:subl :ecx + (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:sbbl :ecx :ecx) + (:negl :ecx) + (:addl 4 :edx) + (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jne 'sub-loop) + (:subl :ecx + (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jnc 'bignum-sub-done) + propagate-carry + (:addl 4 :edx) + (:subl 1 (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jc 'propagate-carry) + bignum-sub-done + ))))) + (((integer 0 *) (integer * -1)) + (+ minuend (- subtrahend))) + (((integer * -1) (integer 0 *)) + (%negatef (+ (- minuend) subtrahend) minuend subtrahend)) + (((integer * -1) (integer * -1)) + (+ minuend (- subtrahend))) + ))) + (do-it))) + (t (minuend &rest subtrahends) + (declare (dynamic-extent subtrahends)) + (if subtrahends + (reduce #'- subtrahends :initial-value minuend) + (- minuend)))))

;;;

(defun zerop (number) (= 0 number))

-(define-compiler-macro zerop (number) - `(= 0 ,number)) - (defun plusp (number) (> number 0))

-(define-compiler-macro plusp (number) - `(> ,number 0)) - (defun minusp (number) (< number 0))

-(define-compiler-macro minusp (number) - `(< ,number 0)) - -(define-compiler-macro abs (x) - `(let ((x ,x)) - (if (>= x 0) x (- x)))) - (defun abs (x) - (abs x)) + (compiler-macro-call abs x))

(defun signum (x) (cond @@ -995,19 +824,10 @@

;;;

-(define-compiler-macro max (&whole form first-number &rest more-numbers) - (case (length more-numbers) - (0 first-number) - (1 `(let ((x ,first-number) - (y ,(car more-numbers))) - (if (>= x y) x y))) - ((2 3 4) - `(max ,first-number (max ,@more-numbers))) - (t form))) - (defun max (number1 &rest numbers) (numargs-case - (2 (x y) (max x y)) + (2 (x y) + (compiler-macro-call max x y)) (t (number1 &rest numbers) (declare (dynamic-extent numbers)) (let ((max number1)) @@ -1015,19 +835,10 @@ (when (> x max) (setq max x)))))))

-(define-compiler-macro min (&whole form first-number &rest more-numbers) - (case (length more-numbers) - (0 first-number) - (1 `(let ((x ,first-number) - (y ,(car more-numbers))) - (if (<= x y) x y))) - ((2 3 4) - `(min ,first-number (min ,@more-numbers))) - (t form))) - (defun min (number1 &rest numbers) (numargs-case - (2 (x y) (min x y)) + (2 (x y) + (compiler-macro-call min x y)) (t (number1 &rest numbers) (declare (dynamic-extent numbers)) (let ((min number1)) @@ -1037,54 +848,6 @@

;; shift

-(define-compiler-macro ash (&whole form integer count &environment env) - (if (not (movitz:movitz-constantp count env)) - form - (let ((count (movitz:movitz-eval count env))) - (cond - ((movitz:movitz-constantp integer env) - (ash (movitz::movitz-eval integer env) count)) - ((= 0 count) - integer) - (t form - #+igore - (let ((load-integer `((:compile-form (:result-mode :register) ,integer) - (:testb ,movitz::+movitz-fixnum-zmask+ (:result-register-low8)) - (:jnz '(:sub-program () (:int 107) (:jmp (:pc+ -4))))))) - (cond - ((<= 1 count 4) - `(with-inline-assembly (:returns :register :side-effects nil) - ,@load-integer - ,@(loop repeat count - append `((:addl (:result-register) (:result-register)) - (:into))))) - ((< 0 count #.(cl:1- movitz::+movitz-fixnum-bits+)) - `(with-inline-assembly (:returns :register :side-effects nil :type integer) - ,@load-integer - (:cmpl ,(ash 1 (- (- 31 0) count)) - (:result-register)) - (:jge '(:sub-program () (:int 4))) - (:cmpl ,(- (ash 1 (- (- 31 0) count))) - (:result-register)) - (:jl '(:sub-program () (:int 4))) - (:shll ,count (:result-register)))) - ((= -1 count) - `(with-inline-assembly (:returns :register :side-effects nil :type integer) - ,@load-integer - (:andb #.(cl:logxor #xfe (cl:* 2 movitz::+movitz-fixnum-zmask+)) (:result-register-low8)) - (:sarl 1 (:result-register)))) - ((> 0 count #.(cl:- (cl:1- movitz::+movitz-fixnum-bits+))) - `(with-inline-assembly (:returns :register :side-effects nil :type integer) - ,@load-integer - (:andl ,(ldb (byte 32 0) - (ash movitz:+movitz-most-positive-fixnum+ - (- movitz:+movitz-fixnum-shift+ count))) - (:result-register)) - (:sarl ,(- count) (:result-register)))) - ((minusp count) - `(if (minusp ,integer) -1 0)) - (t `(if (= 0 ,integer) 0 (with-inline-assembly (:returns :non-local-exit) (:int 4))))))))))) - (defun ash (integer count) (cond ((= 0 count) @@ -1202,30 +965,6 @@

;;; Multiplication

-(define-compiler-macro * (&whole form &rest operands &environment env) - (case (length operands) - (0 0) - (1 (first operands)) - (2 (let ((factor1 (first operands)) - (factor2 (second operands))) - (cond - ((and (movitz:movitz-constantp factor1 env) - (movitz:movitz-constantp factor2 env)) - (* (movitz:movitz-eval factor1 env) - (movitz:movitz-eval factor2 env))) - ((movitz:movitz-constantp factor2 env) - `(* ,(movitz:movitz-eval factor2 env) ,factor1)) - ((movitz:movitz-constantp factor1 env) - (let ((f1 (movitz:movitz-eval factor1 env))) - (check-type f1 integer) - (case f1 - (0 `(progn ,factor2 0)) - (1 factor2) - (2 `(let ((x ,factor2)) (+ x x))) - (t `(no-macro-call * ,factor1 ,factor2))))) - (t `(no-macro-call * ,factor1 ,factor2))))) - (t `(* (* ,(first operands) ,(second operands)) ,@(cddr operands))))) - (defun * (&rest factors) (numargs-case (1 (x) x) @@ -1637,16 +1376,6 @@ (defun byte (size position) (+ (* size #x400) position))

-(define-compiler-macro byte (&whole form size position) - (cond - ((and (integerp size) - (integerp position)) - (+ (* size #x400) position)) - #+ignore - ((integerp size) - `(+ ,position ,(* size #x400))) - (t form))) - (defun byte-size (bytespec) (truncate bytespec #x400))

@@ -1671,24 +1400,6 @@ (:btl :ecx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))))))) (do-it)))

-(define-compiler-macro logand (&whole form &rest integers &environment env) - (let ((constant-folded-integers (loop for x in integers - with folded-constant = -1 - if (and (movitz:movitz-constantp x env) - (not (= -1 (movitz:movitz-eval x env)))) - do (setf folded-constant - (logand folded-constant (movitz:movitz-eval x env))) - else collect x into non-constants - finally (return (if (= -1 folded-constant) - non-constants - (cons folded-constant non-constants)))))) - (case (length constant-folded-integers) - (0 0) - (1 (first constant-folded-integers)) - (2 `(no-macro-call logand ,(first constant-folded-integers) ,(second constant-folded-integers))) - (t `(logand (logand ,(first constant-folded-integers) ,(second constant-folded-integers)) - ,@(cddr constant-folded-integers)))))) - (defun logand (&rest integers) (numargs-case (1 (x) x) @@ -1834,24 +1545,6 @@ 0 (reduce #'logior integers)))))

-(define-compiler-macro logior (&whole form &rest integers &environment env) - (let ((constant-folded-integers (loop for x in integers - with folded-constant = 0 - if (and (movitz:movitz-constantp x env) - (not (zerop (movitz:movitz-eval x env)))) - do (setf folded-constant - (logior folded-constant (movitz:movitz-eval x env))) - else collect x into non-constants - finally (return (if (= 0 folded-constant) - non-constants - (cons folded-constant non-constants)))))) - (case (length constant-folded-integers) - (0 0) - (1 (first constant-folded-integers)) - (2 `(no-macro-call logior ,(first constant-folded-integers) ,(second constant-folded-integers))) - (t `(logior (logior ,(first constant-folded-integers) ,(second constant-folded-integers)) - ,@(cddr constant-folded-integers)))))) - (defun logxor (&rest integers) (numargs-case (1 (x) x) @@ -2271,104 +1964,10 @@ (:edi (:edi-offset atomically-status)))) ldb-done)))) (do-it))))))) - - -(define-compiler-macro ldb%byte (&whole form &environment env size position integer) - "This is LDB with explicit byte-size and position parameters." - (cond - ((and (movitz:movitz-constantp size env) - (movitz:movitz-constantp position env) - (movitz:movitz-constantp integer env)) - (ldb (byte (movitz:movitz-eval size env) - (movitz:movitz-eval position env)) - (movitz:movitz-eval integer env))) ; constant folding - ((and (movitz:movitz-constantp size env) - (movitz:movitz-constantp position env)) - (let* ((size (movitz:movitz-eval size env)) - (position (movitz:movitz-eval position env)) - (result-type `(unsigned-byte ,size))) - (cond - ((or (minusp size) (minusp position)) - (error "Negative byte-spec for ldb.")) - ((= 0 size) - `(progn ,integer 0)) - ((<= (+ size position) (- 31 movitz:+movitz-fixnum-shift+)) - `(with-inline-assembly (:returns :register - :type ,result-type) - (:compile-form (:result-mode :eax) ,integer) - (:call-global-pf unbox-u32) - (:andl ,(mask-field (byte size position) -1) :ecx) - ,@(unless (zerop position) - `((:shrl ,position :ecx))) - (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) (:result-register)))) - ((<= (+ size position) 32) - `(with-inline-assembly-case (:type ,result-type) - (do-case (t :eax :labels (nix done)) - (:compile-form (:result-mode :eax) ,integer) - ,@(cond - ((and (= 0 position) (= 32 size)) - ;; If integer is a positive bignum with one bigit, return it. - `((:leal (:eax ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jnz 'nix) - (:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0)) - (:eax ,movitz:+other-type-offset+)) - (:je 'done))) - ((and (= 0 position) (<= (- 32 movitz:+movitz-fixnum-shift+) size )) - `((:leal (:eax ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jnz 'nix) - (:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0)) - (:eax ,movitz:+other-type-offset+)) - (:jne 'nix) - (:movl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) - :ecx) - (:testl ,(logxor #xffffffff (mask-field (byte size 0) -1)) - :ecx) - (:jz 'done) - (:andl ,(mask-field (byte size 0) -1) - :ecx) - (:call-local-pf box-u32-ecx) - (:jmp 'done)))) - nix - (:call-global-pf unbox-u32) - ,@(unless (= 32 (- size position)) - `((:andl ,(mask-field (byte size position) -1) :ecx))) - ,@(unless (zerop position) - `((:shrl ,position :ecx))) - (:call-local-pf box-u32-ecx) - done))) - (t form)))) - (t form)))

(defun ldb (bytespec integer) (ldb%byte (byte-size bytespec) (byte-position bytespec) integer))

-(define-compiler-macro ldb (&whole form &environment env bytespec integer) - (let ((bytespec (movitz::movitz-macroexpand bytespec env))) - (if (not (and (consp bytespec) (eq 'byte (car bytespec)))) - form - `(ldb%byte ,(second bytespec) ,(third bytespec) ,integer)))) - -(define-setf-expander ldb (bytespec int &environment env) - "Stolen from the Hyperspec example in the define-setf-expander entry." - (multiple-value-bind (temps vals stores store-form access-form) - (get-setf-expansion int env) ;Get setf expansion for int. - (let ((btemp (gensym)) ;Temp var for byte specifier. - (store (gensym)) ;Temp var for byte to store. - (stemp (first stores))) ;Temp var for int to store. - (if (cdr stores) (error "Can't expand this.")) - ;; Return the setf expansion for LDB as five values. - (values (cons btemp temps) ;Temporary variables. - (cons bytespec vals) ;Value forms. - (list store) ;Store variables. - `(let ((,stemp (dpb ,store ,btemp ,access-form))) - ,store-form - ,store) ;Storing form. - `(ldb ,btemp ,access-form) ;Accessing form. - )))) - - (defun ldb-test (bytespec integer) (case (byte-size bytespec) (0 nil) @@ -2456,14 +2055,6 @@ r+1 r))) (setf r next-r)))))) - -(define-compiler-macro expt (&whole form base-number power-number &environment env) - (if (not (and (movitz:movitz-constantp base-number env) - (movitz:movitz-constantp power-number env))) - form - (expt (movitz:movitz-eval base-number env) - (movitz:movitz-eval power-number env)))) -

(defun expt (base-number power-number) "Take base-number to the power-number."