Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv12459
Modified Files:
integers.lisp
Log Message:
Implemented ldb wrt. bignums. It does not work for negative bignums
yet.
Date: Tue Jun 8 13:11:13 2004
Author: ffjeld
Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.25 movitz/losp/muerte/integers.lisp:1.26
--- movitz/losp/muerte/integers.lisp:1.25 Tue Jun 8 01:15:26 2004
+++ movitz/losp/muerte/integers.lisp Tue Jun 8 13:11:13 2004
@@ -9,7 +9,7 @@
;;;; Created at: Wed Nov 8 18:44:57 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: integers.lisp,v 1.25 2004/06/08 08:15:26 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.26 2004/06/08 20:11:13 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -1273,19 +1273,21 @@
(t `(logior (logior%2op ,(first constant-folded-integers) ,(second constant-folded-integers))
,@(cddr constant-folded-integers))))))
-(defun logxor%2op (x y)
- (check-type x fixnum)
- (check-type y fixnum)
- (with-inline-assembly (:returns :eax)
- (:compile-form (:result-mode :eax) x)
- (:compile-form (:result-mode :ebx) y)
- (:xorl :ebx :eax)))
-
(defun logxor (&rest integers)
- (declare (dynamic-extent integers))
- (if (null integers)
- 0
- (reduce #'logxor%2op integers)))
+ (numargs-case
+ (1 (x) x)
+ (2 (x y)
+ (number-double-dispatch (x y)
+ ((fixnum fixnum)
+ (with-inline-assembly (:returns :eax)
+ (:compile-form (:result-mode :eax) x)
+ (:compile-form (:result-mode :ebx) y)
+ (:xorl :ebx :eax)))))
+ (t (&rest integers)
+ (declare (dynamic-extent integers))
+ (if (null integers)
+ 0
+ (reduce #'logxor integers)))))
(defun lognot (integer)
(check-type integer fixnum)
@@ -1294,20 +1296,363 @@
(:xorl #.(cl:- #xffffffff movitz::+movitz-fixnum-zmask+) :eax)))
(defun ldb%byte (size position integer)
- (check-type size fixnum)
- (check-type position fixnum)
- (logand (ash integer (- position))
- (svref #(#x0 #x1 #x3 #x7
- #xf #x1f #x3f #x7f
- #xff #x1ff #x3ff #x7ff
- #xfff #x1fff #x3fff #x7fff
- #xffff #x1ffff #x3ffff #x7ffff
- #xfffff #x1fffff #x3fffff #x7fffff
- #xffffff #x1ffffff #x3ffffff #x7ffffff
- #xfffffff)
- size)))
+ "This is LDB with explicit byte-size and position parameters."
+ (check-type size positive-fixnum)
+ (check-type position positive-fixnum)
+ (etypecase integer
+ (fixnum
+ (macrolet
+ ((do-it ()
+ `(with-inline-assembly (:returns :eax)
+ (:compile-two-forms (:eax :ecx) integer position)
+ (:cmpl ,(* (1- movitz:+movitz-fixnum-bits+) movitz:+movitz-fixnum-factor+)
+ :ecx)
+ (:ja '(:sub-program (outside-fixnum)
+ (:break)
+ (:addl #x80000000 :eax) ; sign into carry
+ (:sbbl :ecx :ecx)
+ (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
+ (:jmp 'mask-fixnum)))
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:std) ; <================= STD
+ (:sarl :cl :eax) ; shift..
+ (:andl ,(logxor #xffffffff movitz:+movitz-fixnum-zmask+) :eax)
+ (:cld) ; =================> CLD
+ mask-fixnum
+ (:compile-form (:result-mode :ecx) size)
+ (:cmpl ,(* (1- movitz:+movitz-fixnum-bits+) movitz:+movitz-fixnum-factor+)
+ :ecx)
+ (:jna 'fixnum-result)
+ (:testl :eax :eax)
+ (:jns 'fixnum-done)
+ ;; We need to generate a bignum..
+ ;; ..filling in 1-bits since the integer is negative.
+ (:pushl :eax) ; This will become the LSB bigit.
+ retry-ones-expanded-bignum
+ (:declare-label-set retry-jumper-ones-expanded-bignum (retry-ones-expanded-bignum))
+ ;; Calculate word-size from bytespec-size.
+ (:compile-form (:result-mode :ecx) size)
+ (:subl ,movitz:+movitz-fixnum-factor+ :ecx) ; Subtract 1
+ (:shrl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; Divide by 32
+ (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ; Add 1 for index->size..
+ ,(* 2 movitz:+movitz-fixnum-factor+)) ; ..and 1 for header.
+ :eax)
+ (:locally (:movl :esp (:edi (:edi-offset atomically-esp))))
+ (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp)
+ 'retry-jumper-ones-expanded-bignum)
+ (:edi (:edi-offset atomically-status))))
+ (:call-global-constant get-cons-pointer)
+ (:shll 16 :ecx)
+ (:addl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) :ecx) ; add 1 for index->size
+ (:movl :ecx (:eax ,movitz:+other-type-offset+))
+ (:shrl 16 :ecx)
+ (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)
+ ,(* 1 movitz:+movitz-fixnum-factor+)) ; add 1 for header.
+ :ecx)
+ (:call-global-constant cons-commit)
+ (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
+ (:edi (:edi-offset atomically-status))))
+ ;; Have fresh bignum in EAX, now fill it with ones.
+ (:xorl :ecx :ecx) ; counter
+ fill-ones-loop
+ (:movl #xffffffff
+ (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+ (:addl 1 :ecx)
+ (:cmpw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)))
+ (:jne 'fill-ones-loop)
+
+ (:popl :ecx) ; The LSB bigit.
+ (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:movl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+ (:movl :eax :ebx)
+ ;; Compute MSB bigit mask in EDX
+ (:compile-form (:result-mode :ecx) size)
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:std) ; <================= STD
+ (:xorl :edx :edx)
+ (:andl 31 :ecx)
+ (:jz 'fixnum-mask-ok)
+ (:addl 1 :edx)
+ (:shll :cl :edx)
+ fixnum-mask-ok
+ (:subl 1 :edx)
+ (:movzxw (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length))
+ :ecx)
+ (:andl :edx ; And EDX with the MSB bigit.
+ (:ebx (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
+ (:movl :edi :edx)
+ (:movl :edi :eax)
+ (:cld) ; =================> CLD
+ (:movl :ebx :eax)
+ (:jmp 'fixnum-done)
+
+ fixnum-result
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:movl ,movitz:+movitz-fixnum-factor+ :edx) ; generate fixnum mask in EDX
+ (:shll :cl :edx)
+ (:subl ,movitz:+movitz-fixnum-factor+ :edx)
+ (:andl :edx :eax)
+ (:jmp 'fixnum-done)
+ fixnum-done
+ )))
+ (do-it)))
+ (positive-bignum
+ (cond
+ ((<= size 32)
+ ;; The result is likely to be a fixnum (or at least an u32), due to byte-size.
+ (macrolet
+ ((do-it ()
+ `(with-inline-assembly (:returns :eax)
+ (:compile-form (:result-mode :ebx) integer)
+ (:compile-form (:result-mode :eax) position)
+ (:movl :eax :ecx) ; compute bigit-number in ecx
+ (:sarl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx)
+ (:addl 1 :ecx)
+ (:cmpl #x10000 :ecx)
+ (:jae 'position-outside-integer)
+ (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+ (:jc '(:sub-program (position-outside-integer)
+ (:movsxb (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign)) :ecx)
+ (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
+ (:jmp 'done-u32)))
+ (:std)
+ (:movl (:ebx (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+ :eax)
+ (:movl 0 :edx) ; If position was in last bigit.. (don't touch EFLAGS)
+ (:je 'no-top-bigit) ; ..we must zero-extend rather than read top bigit.
+ (:movl (:ebx (:ecx 4) ,(+ 0 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+ :edx) ; Read top bigit into EDX
+ no-top-bigit
+ (:testl #xff00 (:ebx ,movitz:+other-type-offset+))
+ (:jnz '(:sub-program (negative-bignum)
+ ;; We must negate the bigits..
+ (:break)
+ ))
+ edx-eax-ok
+ ;; EDX:EAX now holds the number that must be shifted and masked.
+ (:compile-form (:result-mode :ecx) position)
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:shrdl :cl :edx :eax) ; Shifted value into EAX
+ (:compile-form (:result-mode :ecx) size)
+ (:xorl :edx :edx) ; Generate a mask in EDX
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:testl 31 :ecx)
+ (:jz 'mask-ok-u32)
+ (:addl 1 :edx)
+ (:shll :cl :edx)
+ mask-ok-u32
+ (:subl 1 :edx)
+ (:andl :edx :eax)
+ (:movl :eax :ecx) ; For boxing..
+ (:movl :edi :eax)
+ (:movl :edi :edx)
+ (:cld)
+ ;; See if we can return same bignum..
+ (:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0))
+ (:ebx ,movitz:+other-type-offset+))
+ (:jne 'cant-return-same)
+ (:cmpl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+ (:jne 'cant-return-same)
+ (:movl :ebx :eax)
+ (:jmp 'done-u32)
+ cant-return-same
+ (:call-global-constant box-u32-ecx)
+ done-u32
+ )))
+ (do-it)))
+ (t (macrolet
+ ((do-it ()
+ `(let ()
+ (with-inline-assembly (:returns :eax)
+ (:compile-form (:result-mode :ebx) integer)
+ (:compile-form (:result-mode :ecx) position)
+ (:shrl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; compute bigit-number in ecx
+ (:cmpl #x10000 :ecx)
+ (:jnc 'position-outside-integer)
+ (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+ (:jbe '(:sub-program (position-outside-integer)
+ (:movsxb (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign)) :ecx)
+ (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
+ (:jmp 'done-u32)))
+
+ (:compile-two-forms (:edx :ecx) position size)
+ (:movl :ecx :eax) ; keep size/fixnum in EAX.
+ (:addl :edx :ecx)
+ (:into) ; just to make sure
+ (:shrl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; compute msb bigit index in ecx
+ (:addl 1 :ecx)
+ (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+ (je '(:sub-program (equal-size-maybe-return-same)
+ (:testl :edx :edx) ; Can only return same if (zerop position).
+ (:jnz 'adjust-size)
+ (:movl :eax :ecx) ; size/fixnum
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:andl 31 :ecx)
+ (:jz 'yes-return-same)
+ (:std) ; <================
+ ;; we know EDX=0, now generate mask in EDX
+ (:addl 1 :edx)
+ (:shll :cl :edx)
+ (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+ :ecx)
+ (:cmpl :edx (:ebx (:ecx 4)
+ ,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))))
+ (:movl 0 :edx) ; Safe value, and correct if we need to go to adjust-size.
+ (:cld) ; =================>
+ (:jnc 'adjust-size) ; nope, we have to generate a new bignum.
+ yes-return-same
+ (:movl :ebx :eax) ; yep, we can return same bignum.
+ (:jmp 'ldb-done)))
+ (:jnc 'size-ok)
+ ;; We now know that (+ size position) is beyond the size of the bignum.
+ ;; So, if (zerop position), we can return the bignum as our result.
+ (:testl :edx :edx)
+ (:jz '(:sub-program ()
+ (:movl :ebx :eax) ; return the source bignum.
+ (:jmp 'ldb-done)))
+ adjust-size
+ ;; The bytespec is (partially) outside source-integer, so we make the
+ ;; size smaller before proceeding. new-size = (- source-int-length position)
+ (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+ :ecx) ; length of source-integer
+ (:shll ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; fixnum bit-position
+ (:xorl :eax :eax) ; In case the new size is zero.
+ (:subl :edx :ecx) ; subtract position
+ (:js '(:sub-program (should-not-happen)
+ ;; new size should never be negative.
+ (:break)))
+ (:jz 'ldb-done) ; New size was zero, so the result of ldb is zero.
+ (:movl :ecx :eax) ; New size into EAX.
+ size-ok
+ retry
+ (:declare-label-set retry-jumper (retry))
+ (: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))))
+ ;; (new) Size is in EAX.
+ (:pushl :eax) ; Save for later
+ (:subl ,movitz:+movitz-fixnum-factor+ :eax)
+ (:andl ,(logxor #xffffffff
+ (mask-field (byte (+ 5 movitz:+movitz-fixnum-shift+) 0) -1))
+ :eax)
+ (:shrl 5 :eax) ; Divide (size-1) by 32 to get number of bigits-1
+ ;; Now add 1 for index->size, 1 for header, and 1 for tmp storage before shift.
+ (:addl ,(* 3 movitz:+movitz-fixnum-factor+) :eax)
+ (:pushl :eax)
+ (:call-global-constant get-cons-pointer)
+ ;; (:store-lexical (:lexical-binding r) :eax :type t)
+ (:popl :ecx)
+ (:subl ,(* 2 movitz:+movitz-fixnum-factor+) :ecx) ; for tmp storage and header.
+ (:shll ,(- 16 movitz:+movitz-fixnum-shift+) :ecx)
+ (:orl ,(movitz:tag :bignum 0) :ecx)
+ (:movl :ecx (:eax ,movitz:+other-type-offset+))
+ (:compile-form (:result-mode :ebx) integer)
+
+ (:xchgl :eax :ebx)
+ ;; now: EAX = old integer, EBX = new result bignum
+
+ ;; Edge case: When size(old)=size(new), the tail-tmp must be zero.
+ ;; We check here, setting the tail-tmp to a mask for and-ing below.
+ (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+ :ecx) ; length of source-integer
+ ;; Initialize tail-tmp to #xffffffff, meaning copy from source-integer.
+ (:movl #xffffffff
+ (:ebx (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+ (:cmpw :cx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+ (:jc '(:sub-program (result-too-big-shouldnt-happen)
+ (:break)))
+ (:jne 'tail-tmp-ok)
+ ;; Sizes was equal, so set tail-tmp to zero.
+ (:movl 0 (:ebx (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+ tail-tmp-ok
+ ;; Now copy the relevant part of the integer
+ (:std)
+ (:compile-form (:result-mode :ecx) position)
+ (:sarl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; compute bigit-number in ecx
+ ;; We can use primitive pointers because we're both inside atomically and std.
+ (:leal (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+ :eax) ; Use EAX as primitive pointer into source
+ (:xorl :ecx :ecx) ; counter
+ copy-integer
+ (:movl (:eax) :edx)
+ (:addl 4 :eax)
+ (:movl :edx (:ebx (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+ (:addl 1 :ecx)
+ (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+ (:jne 'copy-integer)
+ ;; Copy one more than the length, namely the tmp at the end.
+ ;; Tail-tmp was initialized to a bit-mask above.
+ (:movl (:eax) :edx)
+ (:andl :edx (:ebx (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+ ;; Copy done, now shift
+ (:compile-form (:result-mode :ecx) position)
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:andl 31 :ecx)
+ (:jz 'shift-done) ; if (zerop (mod position 32)), no shift needed.
+ (:xorl :edx :edx) ; counter
+ shift-loop
+ (:movl (:ebx (:edx 4) ,(+ 4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+ :eax) ; Next bigit into eax
+ (:shrdl :cl :eax ; Now shift bigit, with msbs from eax.
+ (:ebx (:edx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+ (:addl 1 :edx)
+ (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+ (:jne 'shift-loop)
+ shift-done
+ ;; Now we must mask MSB bigit.
+ (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+ :edx)
+ (:popl :ecx) ; (new) bytespec size
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:andl 31 :ecx)
+ (:jz 'mask-done)
+ (:movl 1 :eax) ; Generate mask in EAX
+ (:shll :cl :eax)
+ (:subl 1 :eax)
+ (:andl :eax
+ (:ebx (:edx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
+ mask-done
+ (:movl :edi :edx) ; safe EDX
+ (:movl :edi :eax) ; safe EAX
+ (:cld)
+ ;; Now we must zero-truncate the result bignum in EBX.
+ (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))
+ :ecx)
+ zero-truncate-loop
+ (:cmpl 0 (:ebx (:ecx 4)
+ ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))
+ (:jne 'zero-truncate-done)
+ (:subl 1 :ecx)
+ (:jnz 'zero-truncate-loop)
+ ;; Zero bigits means the entire result collapsed to zero.
+ (:xorl :eax :eax)
+ (:jmp 'return-fixnum) ; don't commit the bignum allocation.
+ zero-truncate-done
+ (:cmpl 1 :ecx) ; If result size is 1, the result might have..
+ (:jne 'complete-bignum-allocation) ; ..collapsed to a fixnum.
+ (:cmpl ,movitz:+movitz-most-positive-fixnum+
+ (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+ (:ja 'complete-bignum-allocation)
+ (:movl (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))
+ :ecx)
+ (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
+ (:jmp 'return-fixnum)
+ complete-bignum-allocation
+ (:movw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+ (:movl :ebx :eax)
+ (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+)
+ :ecx)
+ (:call-global-constant cons-commit)
+ return-fixnum
+ (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
+ (: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)
@@ -1414,7 +1759,6 @@
(defun dpb (newbyte bytespec integer)
(logior (mask-field bytespec (ash newbyte (byte-position bytespec)))
(logandc2 integer (mask-field bytespec -1))))
-
(defun mask-field (bytespec integer)
(ash (ldb bytespec integer) (byte-position bytespec)))
