Index: /branches/arm/level-0/ARM/arm-bignum.lisp
===================================================================
--- /branches/arm/level-0/ARM/arm-bignum.lisp	(revision 13805)
+++ /branches/arm/level-0/ARM/arm-bignum.lisp	(revision 13805)
@@ -0,0 +1,1131 @@
+;;-*- Mode: Lisp; Package: CCL -*-
+;;;
+;;;   Copyright (C) 2010 Clozure Associates
+
+;;;   This file is part of Clozure CL.  
+;;;
+;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with Clozure CL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+
+(in-package "CCL")
+
+(eval-when (:compile-toplevel :execute)
+  (require "ARM-ARCH")
+  (require "ARM-LAPMACROS"))
+
+;;; %BIGNUM-REF needs to access bignums as obviously as possible, and it needs
+;;; to be able to return 32 bits somewhere no one looks for real objects.
+;;;
+;;; The easiest thing to do is to store the 32 raw bits in two fixnums
+;;; and return multiple values.
+(defarmlapfunction %bignum-ref ((bignum arg_y) (i arg_z))
+  (vref32 imm0 bignum i imm1)
+  (digit-h temp0 imm0)
+  (digit-l temp1 imm0)
+  (vpush1 temp0)
+  (vpush1 temp1)
+  (add temp0 vsp (:$ 8))                  
+  (set-nargs 2)                         
+  (ba .SPvalues))
+
+
+;;; Set the 0th element of DEST (a bignum or some other 32-bit ivector)
+;;; to the Ith element of the bignum SRC.
+(defarmlapfunction %ref-digit ((bignum arg_x) (i arg_y) (dest arg_z))
+  (add imm1 i (:$ arm::misc-data-offset))
+  (ldr imm0 (:@ bignum imm1))
+  (str imm0 (:@ dest (:$ arm::misc-data-offset)))
+  (bx lr))
+
+;;; BIGNUM[I] := DIGIT[0]
+(defarmlapfunction %set-digit ((bignum arg_x) (i arg_y) (digit arg_z))
+  (add imm1 i (:$ arm::misc-data-offset))
+  (ldr imm0 (:@ digit (:$ arm::misc-data-offset)))
+  (str imm0 (:@ bignum imm1))
+  (bx lr))
+
+
+
+
+
+;;; Return the sign of bignum (0 or -1) as a fixnum
+(defarmlapfunction %bignum-sign ((bignum arg_z))
+  (vector-length imm0 bignum imm0)
+  (add imm0 imm0 (:$ (- arm::misc-data-offset 4))) ; Reference last (most significant) digit
+  (ldr imm0 (:@ bignum imm0))
+  (mov imm0 (:asr imm0 (:$ 31)))        ;propagate sign bit
+  (box-fixnum arg_z imm0)
+  (bx lr))
+
+;;; Count the sign bits in the most significant digit of bignum;
+;;; return fixnum count.
+(defarmlapfunction %bignum-sign-bits ((bignum arg_z))
+  (vector-length imm0 bignum imm0)
+  (add imm0 imm0 (:$ (- arm::misc-data-offset 4))) ; Reference last (most significant) digit
+  (ldr imm0 (:@ bignum imm0))
+  (cmp imm0 (:$ 0))
+  (mvnlt imm0 imm0)
+  (clz imm0 imm0)
+  (box-fixnum arg_z imm0)
+  (bx lr))
+
+(defarmlapfunction %digit-0-or-plusp ((bignum arg_y) (idx arg_z))
+  (add imm0 idx (:$ arm::misc-data-offset))
+  (ldr imm0 (:@ bignum imm0))
+  (mov arg_z 'nil)
+  (cmp imm0 (:$ 0))
+  (addge arg_z arg_z (:$ arm::t-offset))
+  (bx lr))
+
+;;; For oddp, evenp
+(defarmlapfunction %bignum-oddp ((bignum arg_z))
+  (ldr imm0 (:@ bignum (:$ arm::misc-data-offset)))
+  (mov arg_z 'nil)
+  (tst imm0 (:$ 1))
+  (addne arg_z arg_z (:$ arm::t-offset))
+  (bx lr))
+  
+(defarmlapfunction bignum-plusp ((bignum arg_z))
+  (vector-length imm0 bignum imm0)
+  (add imm0 imm0 (:$ (- arm::misc-data-offset 4))) ; Reference last (most significant) digit
+  (ldr imm0 (:@ bignum imm0))
+  (mov arg_z 'nil)
+  (cmp imm0 (:$ 0))
+  (addge arg_z arg_z (:$ arm::t-offset))
+  (bx lr))
+
+(defarmlapfunction %fixnum-to-bignum-set ((bignum arg_y) (fixnum arg_z))
+  (unbox-fixnum imm0 fixnum)
+  (str imm0 (:@ bignum  (:$ arm::misc-data-offset)))
+  (bx lr))
+
+(defarmlapfunction bignum-minusp ((bignum arg_z))
+  (vector-length imm0 bignum imm0)
+  (add imm0 imm0 (:$ (- arm::misc-data-offset 4))) ; Reference last (most significant) digit
+  (ldr imm0 (:@ bignum imm0))
+  (mov arg_z 'nil)
+  (cmp imm0 (:$ 0))
+  (addlt arg_z arg_z (:$ arm::t-offset))
+  (bx lr))
+
+
+;;; Add the digits A[I] and B[J], and the incoming carry C (a fixnum).
+;;; Store the result in R[K], and return the outgoing carry.
+;;; If I is NIL, A is a fixnum.  If J is NIL, B is a fixnum.
+
+(defarmlapfunction %add-with-carry ((r 12) (k 8) (c 4) (a 0) (i arg_x) (b arg_y) (j arg_z))
+  (cmp i 'nil)
+  (ldr temp0 (:@ vsp (:$ a)))
+  (moveq imm1 (:asr temp0 (:$ arm::fixnumshift)))
+  (addne imm1 i (:$ arm::misc-data-offset))
+  (ldrne imm1 (:@ temp0 imm1))
+  (cmp j 'nil)
+  (moveq imm2 (:asr b (:$ arm::fixnumshift)))
+  (addne imm2 j (:$ arm::misc-data-offset))
+  (ldrne imm2 (:@ b imm2))
+  (ldr temp0 (:@ vsp (:$ c)))
+  (unbox-fixnum imm0 temp0)
+  (subs imm0 imm0 (:$ 1))
+  (ldr temp1 (:@ vsp (:$ r)))
+  (ldr temp0 (:@ vsp (:$ k)))
+  (add vsp vsp (:$ 16))  
+  (adc imm0 imm1 imm2)
+  (add imm2 temp0 (:$ arm::misc-data-offset))
+  (str imm0 (:@ temp1 imm2))
+  (mov imm0 (:$ 0))
+  (adc imm0 imm0 (:$ 0))
+  (box-fixnum arg_z imm0)
+  (bx lr))
+
+
+
+
+    
+;;; Store the result of A[I] - B[J] - borrow into R[K], returning the borrow.
+;;; If I is NIL, A is a fixnum; likewise for J and B.
+#+notyet
+(defarmlapfunction %subtract-with-borrow ((r 12) (k 8) (borrow 4) (a 0) (i arg_x) (b arg_y) (j arg_z))
+  (cmpwi cr0 i arm::nil-value)
+  (cmpwi cr1 j arm::nil-value)
+  (ldr temp0 vsp (:$ a))
+  (unbox-fixnum imm2 b)
+  (unbox-fixnum imm1 temp0)
+  (beq cr1 @got-b)
+  (add imm2 j (:$ arm::misc-data-offset))
+  (ldr imm2 (:@ b imm2))
+  @got-b
+  (beq cr0 @got-a)
+  (add imm1 i (:$ arm::misc-data-offset))
+  (ldr imm1 (:@ temp0 imm1))
+  @got-a
+  (ldr temp0 vsp (:$ borrow))
+  (unbox-fixnum imm0 temp0)
+  (addic imm0 imm0 -1)
+  (ldr temp0 vsp (:$ r))
+  (ldr temp1 vsp (:$ k))
+  (add vsp vsp (:$ 16))  
+  (subfe imm0 imm2 imm1)
+  (add imm1 temp1 (:$ arm::misc-data-offset))
+  (str imm0 (:@ temp0 imm1))
+  (addze imm0 rzero)
+  (box-fixnum arg_z imm0)
+  (bx lr))
+
+;; multiply i'th digit of x by y and add to result starting at digit i
+#+notyet
+(defarmlapfunction %multiply-and-add-harder-loop-2
+    ((x-ptr 4) (y-ptr 0) (resptr arg_x)(residx arg_y) (count arg_z))  
+  (let ((tem imm0)
+        (y imm1)
+        (prod-h imm2)
+        (prod-l imm3)
+        (x imm4)
+        (xptr temp2)
+        (yidx temp1)
+        (yptr temp0))
+    (ldr xptr vsp (:$ x-ptr))
+    (add tem residx (:$ arm::misc-data-offset))
+    (ldr x (:@ xptr tem))
+    (ldr yptr vsp (:$ y-ptr))
+    (li yidx 0) ; init yidx 0 
+    (addc prod-h rzero rzero) ; init carry 0, mumble 0
+    @loop
+    (subi count count '1)
+    (cmpwi count 0)
+    (add tem yidx (:$ arm::misc-data-offset))   ; get yidx
+    (ldr y (:@ yptr tem)) 
+    (mullw prod-l x y)
+    (addc prod-l prod-l prod-h)
+    (mulhwu prod-h x y)
+    (addze prod-h prod-h)
+    (add tem residx (:$ arm::misc-data-offset))
+    (ldr y (:@ resptr tem))    
+    (addc prod-l prod-l y)
+    (addze prod-h prod-h)
+    (str prod-l (:@ resptr tem))    
+    (addi residx residx '1)
+    (addi yidx yidx '1)
+    (bgt @loop)
+    (add tem residx (:$ arm::misc-data-offset))
+    (str prod-h (:@ resptr tem))
+    (add vsp vsp (:$ 8))      
+    (bx lr)))
+
+
+
+;;; Multiply X[I] by the unboxed value of the (non-negative) fixnum Y;
+;;; add the incoming carry from CARRY[0] to the 64-bit product.  Store
+;;; the low word of the 64-bit sum in R[0] and the high word in
+;;; CARRY[0].
+
+#+notyet
+(defarmlapfunction %multiply-and-add ((r 4) (carry 0) (x arg_y) (i arg_x) (y arg_z))
+  (unbox-fixnum imm0 arg_z)
+  (add imm1 i (:$ arm::misc-data-offset))
+  (ldr imm1 (:@ x imm1))
+  (mulhwu imm2 imm0 imm1)
+  (mullw imm1 imm0 imm1)
+  (ldr temp0 vsp (:$ carry))
+  (ldr imm0 temp0 (:$ arm::misc-data-offset))
+  (addc imm1 imm1 imm0)
+  (addze imm2 imm2)
+  (str imm2 temp0  (:$ arm::misc-data-offset))
+  (ldr arg_z vsp (:$ r))
+  (add vsp vsp (:$ 8))    
+  (str imm1 arg_z  (:$ arm::misc-data-offset))
+  (bx lr))
+  
+
+
+(defarmlapfunction %bignum-ref-hi ((bignum arg_y) (i arg_z))
+  (add imm1 i (:$ (+ 2 arm::misc-data-offset)))
+  (ldrh imm0 (:@ bignum imm1))
+  (box-fixnum arg_z imm0)
+  (bx lr))
+
+
+(defarmlapfunction %bignum-set ((bignum 0) (i arg_x) (high arg_y) (low arg_z))
+  (compose-digit imm0 high low)
+  (ldr arg_z (:@ vsp (:$ bignum)))
+  (vset32 imm0 arg_z i imm1)
+  (add vsp vsp (:$ 4))
+  (bx lr))
+
+
+
+
+; this is silly
+#+notyet
+(defarmlapfunction %add-the-carry ((b-h arg_x) (b-l arg_y) (carry-in arg_z))
+  (let ((a imm0)
+        (b imm1)
+        (temp imm2)
+        (c imm3))    
+    (compose-digit b b-h b-l)
+    (unbox-fixnum c carry-in)
+    (add b c b)
+    (digit-h temp0 b)
+    (digit-l temp1 b)
+    (vpush temp0)
+    (vpush temp1)
+    (add temp0 vsp (:$ 8))
+    (set-nargs 2)
+    (ba .SPvalues)))
+
+
+
+
+;;; %SUBTRACT-WITH-BORROW -- Internal.
+;;;
+;;; This should be in assembler, and should not cons intermediate results.  It
+;;; returns a 32bit digit and a borrow resulting from subtracting b from a, and
+;;; subtracting a possible incoming borrow.
+;;;
+;;; We really do:  a - b - 1 + borrow, where borrow is either 0 or 1.
+;;; 
+
+#+notyet
+(defarmlapfunction %subtract-with-borrow-1 ((a-h 4) (a-l 0) (b-h arg_x) (b-l
+arg_y) (borrow-in arg_z))
+  (let ((a imm0)
+        (b imm1)
+        (temp imm2)
+        (c imm3))
+    (ldr temp0 vsp (:$ a-h))
+    (ldr temp1 vsp (:$ a-l))
+    (compose-digit a temp0 temp1)
+    (compose-digit b b-h b-l)
+    (unbox-fixnum c borrow-in)
+    (li temp -1)
+    (addc temp c temp)
+    (subfe a b a)
+    (addze c rzero)
+    (box-fixnum c c)
+    (digit-h temp0 a)
+    (digit-l temp1 a)
+    (vpush temp0)
+    (vpush temp1)
+    (vpush c)
+    (add temp0 vsp (:$ 20))
+    (set-nargs 3)
+    (ba .SPvalues)))
+
+
+#+notyet
+(defarmlapfunction %subtract-one ((a-h arg_y)(a-l arg_z))
+  (let ((a imm0))
+    (compose-digit a a-h a-l)
+    (subi a a 1)
+    (digit-h temp0 a)
+    (vpush temp0)
+    (digit-l temp0 a)
+    (vpush temp0)
+    (add temp0 vsp (:$ 8))
+    (set-nargs 2)
+    (ba .spvalues)))
+
+
+
+
+;;; %MULTIPLY-AND-ADD  --  Internal.
+;;;
+;;; This multiplies x-digit and y-digit, producing high and low digits
+;;; manifesting the result.  Then it adds the low digit, res-digit, and
+;;; carry-in-digit.  Any carries (note, you still have to add two digits at a
+;;; time possibly producing two carries) from adding these three digits get
+;;; added to the high digit from the multiply, producing the next carry digit.
+;;; Res-digit is optional since two uses of this primitive multiplies a single
+;;; digit bignum by a multiple digit bignum, and in this situation there is no
+;;; need for a result buffer accumulating partial results which is where the
+;;; res-digit comes from.
+;;; [slh] I assume that the returned carry "digit" can only be 0, 1 or 2
+
+
+#+notyet
+(defarmlapfunction %multiply-and-add-1 ((x-high 8)
+					(x-low 4)
+					(y-high 0)
+					(y-low arg_x)
+					(carry-in-high arg_y)
+					(carry-in-low arg_z))
+  (let ((x imm0)
+	(y imm1)
+	(carry-in imm2)
+	(lo imm3)
+	(hi imm4))
+    (compose-digit carry-in carry-in-high carry-in-low)
+    (vpop temp0)
+    (compose-digit y temp0 y-low)
+    (vpop temp0)
+    (vpop temp1)
+    (compose-digit x temp1 temp0)
+    (mullw lo x y)
+    (mulhwu hi x y)
+    (addc lo lo carry-in)
+    (addze hi hi)
+    (digit-h temp0 hi)
+    (digit-l temp1 hi)
+    (digit-h temp2 lo)
+    (digit-l temp3 lo)
+    (vpush temp0)
+    (vpush temp1)
+    (vpush temp2)
+    (vpush temp3)
+    (set-nargs 4)
+    (add temp0 vsp (:$ 16))
+    (ba .SPvalues)))
+
+
+(defarmlapfunction %logcount-complement ((bignum arg_y) (idx arg_z))
+  (let ((arg imm0)
+        (shift imm1)
+        (temp imm2))
+    (add arg idx (:$ arm::misc-data-offset))
+    (ldr arg (:@ bignum arg))
+    (mvns shift arg)
+    (mov arg_z '0)
+    (bxeq lr)
+    @loop
+    (add temp shift (:$ -1))
+    (ands shift shift temp)
+    (add arg_z arg_z (:$ '1))
+    (bne @loop)
+    (bx lr)))
+
+(defarmlapfunction %logcount ((bignum arg_y) (idx arg_z))
+  (let ((arg imm0)
+        (shift imm1)
+        (temp imm2))
+    (add arg idx (:$ arm::misc-data-offset))
+    (ldr arg (:@ bignum arg))
+    (movs shift arg)
+    (mov arg_z '0)
+    (bxeq lr)
+    @loop
+    (add temp shift (:$ -1))
+    (ands shift shift temp)
+    (add arg_z arg_z '1)
+    (bne @loop)
+    (bx lr)))
+
+; return res
+#+notyet
+(defarmlapfunction bignum-add-loop-2 ((aptr arg_x)(bptr arg_y) (result arg_z))
+  (let ((idx imm0)
+        (count imm1)
+        (x imm2)
+        (y imm3)        
+        (len-a temp0)
+        (len-b temp1)
+        (tem temp2))
+    (li idx arm::misc-data-offset)    
+    (ldr imm4 aptr (:$ arm::misc-header-offset))
+    (header-length len-a imm4)
+    (ldr imm4 bptr (:$ arm::misc-header-offset))
+    (header-length len-b imm4)
+    ; make a be shorter one
+    (cmpw len-a len-b)
+    (li count 0)
+    ; initialize carry 0
+    (addc x rzero rzero)
+    (ble @loop)
+    ; b shorter - swap em
+    (mr tem len-a)
+    (mr len-a len-b)
+    (mr len-b tem)
+    (mr tem aptr)
+    (mr aptr bptr)
+    (mr bptr tem)    
+    @loop
+    (ldr y (:@ aptr idx))
+    (ldr x (:@ bptr idx))    
+    (addi count count '1)
+    (cmpw count len-a)
+    (adde x x y)
+    (str x (:@ result idx))
+    (addi idx idx '1)
+    (blt @loop)
+    ; now propagate carry thru longer (b) using sign of shorter    
+    ;(SUBI imm4 idx '1) ; y has hi order word of a
+    ;(ldr y (:@ aptr imm4))
+    (cmpw len-a len-b)
+    (adde imm4 rzero rzero) ; get carry
+    (srawi y y 31)  ; p.o.s clobbers carry 
+    (addic imm4 imm4 -1)  ; restore carry
+    (beq @l3)  ; unless equal
+    @loop2
+    (ldr x (:@ bptr idx))
+    (adde x x y)
+    (str x (:@ result idx))
+    (addi count count '1)
+    (cmpw count len-b)
+    (addi idx idx '1)
+    (blt @loop2)
+    ; y has sign of shorter - get sign of longer to x
+    @l3
+    (subi imm4 idx '1)
+    (ldr x (:@ bptr imm4))
+    (adde imm4 rzero rzero) ; get carry
+    (srawi x x 31)  ; clobbers carry 
+    (addic imm4 imm4 -1)
+    (adde x x y)
+    (str x (:@ result idx))
+    (bx lr)))
+
+;; same as above but with initial a index and finishes
+#+notyet
+(defarmlapfunction bignum-add-loop-+ ((init-a 0)(aptr arg_x)(bptr arg_y)(length arg_z))
+  (let ((idx imm0)        
+        (count imm1)
+        (x imm2)
+        (y imm3)
+        (aidx imm4))
+    (li idx arm::misc-data-offset)
+    (ldr aidx vsp (:$ init-a))
+    (addi aidx aidx arm::misc-data-offset)
+    (li count 0)
+    ; initialize carry 0
+    (addc x rzero rzero)
+    @loop
+    (ldr x (:@ aptr aidx))
+    (ldr y (:@ bptr idx))
+    (adde x x y)
+    (str x (:@ aptr aidx))
+    (addi count count '1)
+    (cmpw count length)
+    (addi idx idx '1)
+    (addi aidx aidx '1)
+    (blt @loop)
+    (ldr x (:@ aptr aidx))  ; add carry into next one
+    (adde x x  rzero)
+    (str x (:@ aptr aidx))
+    (add vsp vsp (:$ 4))
+    (bx lr)))
+
+
+#+notyet
+(defarmlapfunction bignum-negate-loop-really ((big arg_x) (len arg_y) (result arg_z))
+  (let ((idx imm0)
+        (one imm1)
+        (x imm2))
+    (li idx arm::misc-data-offset)
+    (li one '1)
+    ; initialize carry 1
+    (li x -1)
+    (addic x x 1)
+    @loop        
+    ;(addi count count '1)    
+    ;(cmpw count len)
+    (subf. len one len)
+    (ldr x (:@ big idx))
+    (not x x)
+    (adde x x rzero)
+    (str x (:@ result idx))    
+    (addi idx idx '1)
+    (bgt @loop)
+    ; return carry
+    (li x 0)
+    (adde x x  rzero)
+    (box-fixnum arg_z x)
+    (bx lr)))
+
+#+notyet
+(defarmlapfunction bignum-negate-to-pointer ((big arg_x) (len arg_y) (result arg_z))
+  (let ((idx imm0)
+        (one imm1)
+        (x imm2)
+        (oidx imm3)
+        (ptr imm4))
+    (li idx arm::misc-data-offset)
+    (li oidx 0)
+    (macptr-ptr ptr result)
+    (li one '1)
+    ; initialize carry 1
+    (li x -1)
+    (addic x x 1)
+    @loop        
+    ;(addi count count '1)    
+    ;(cmpw count len)
+    (subf. len one len)
+    (ldr x (:@ big idx))
+    (not x x)
+    (adde x x rzero)
+    (str x (:@ ptr oidx))    
+    (addi idx idx '1)
+    (addi oidx oidx 4)
+    (bgt @loop)
+    ; return carry
+    (li x 0)
+    (adde x x  rzero)
+    (box-fixnum arg_z x)
+    (bx lr)))
+
+;; she do tolerate len = jidx
+#+notyet
+(defarmlapfunction bignum-shift-left-loop ((nbits 4)(result 0) (bignum arg_x) (len arg_y) (jidx arg_z))
+  (let ((y imm0)
+        (idx imm1)
+        (bits imm2)
+        (rbits imm3)
+        (x imm4)
+        (iidx temp0)
+        (resptr temp1))
+    (li iidx 0)
+    (ldr bits vsp (:$ nbits))
+    (ldr resptr vsp (:$ result))
+    (unbox-fixnum bits bits)
+    (subfic rbits bits 32)    
+    ;(dbg)
+    (ldr imm4 bignum (:$ arm::misc-data-offset))
+    (slw imm4 imm4 bits)
+    (add y jidx (:$ (+ arm::misc-data-offset -4)))  
+    (str imm4 (:@ y resptr)) 
+     
+    (cmpw len jidx)
+    (beq @done)
+    @loop
+    (addi idx iidx arm::misc-data-offset)
+    (ldr x (:@ bignum idx))
+    (srw x x rbits)
+    (addi idx idx '1)
+    (ldr y (:@ bignum idx))
+    (slw y y bits)
+    (or x x y)
+    (addi idx jidx arm::misc-data-offset)
+    (str x (:@ resptr idx))
+    (addi jidx jidx '1)    
+    (cmpw jidx len)
+    (addi iidx iidx '1)
+    (blt @loop)    
+    @done
+    ; do first - lo order
+       
+    ; do last - hi order    
+    (addi idx iidx arm::misc-data-offset)
+    ;(dbg t)
+    (ldr y (:@ bignum idx))
+    (sraw y y rbits)
+    (addi idx len arm::misc-data-offset)
+    (str y (:@ resptr idx))
+    (add vsp vsp (:$ 8))
+    (bx lr)))
+
+
+#+notyet
+(defarmlapfunction bignum-shift-right-loop-1 ((nbits 4)(result 0) (bignum arg_x) (len arg_y) (iidx arg_z))
+  (let ((y imm0)
+        (idx imm1)
+        (bits imm2)
+        (rbits imm3)
+        (x imm4)
+        (jidx temp0)
+        (resptr temp1))
+    (li jidx 0)
+    (ldr bits vsp (:$ nbits))
+    (ldr resptr vsp (:$ result))
+    (unbox-fixnum bits bits)
+    (cmpw jidx len)
+    (subfic rbits bits 32)    
+    (bge @done)
+    @loop
+    (addi idx iidx arm::misc-data-offset)
+    (ldr x (:@ bignum idx))
+    (srw x x bits)
+    (addi idx idx '1)
+    (ldr y (:@ bignum idx))
+    (slw y y rbits)
+    (or x x y)
+    (addi idx jidx arm::misc-data-offset)
+    (str x (:@ resptr idx))
+    (addi jidx jidx '1)    
+    (cmpw jidx len)
+    (addi iidx iidx '1)
+    (blt @loop)
+    @done
+    (addi idx iidx arm::misc-data-offset)
+    (ldr x (:@ bignum idx))
+    (sraw x x bits)
+    (addi idx jidx arm::misc-data-offset)
+    (str x (:@ resptr idx))
+    (add vsp vsp (:$ 8))
+    (bx lr)))
+
+
+(defarmlapfunction %compare-digits ((a arg_x) (b arg_y) (idx arg_z))
+  (add imm0 idx (:$ arm::misc-data-offset))
+  (ldr imm1 (:@ a imm0))
+  (ldr imm0 (:@ b imm0))
+  (cmp imm1 imm0)
+  (moveq arg_z '0)
+  (movhi arg_z '1)
+  (movlo arg_z '-1)
+  (bx lr))
+
+
+  
+;; returns number of bits in digit-hi,digit-lo that are sign bits
+;; 32 - digits-sign-bits is integer-length
+
+(defarmlapfunction %digits-sign-bits ((hi arg_y) (lo arg_z))
+  (compose-digit imm1 hi lo)
+  (cmp imm1 (:$ 0))
+  (mvnlt imm1 imm1)
+  (clz imm1 imm1)
+  (box-fixnum arg_z imm1)
+  (bx lr))
+
+(defarmlapfunction bignum-logtest-loop ((count arg_x) (b1 arg_y) (b2 arg_z))  
+  (mov imm1 (:$ arm::misc-data-offset))
+  @loop
+  (ldr imm2 (:@ b1 imm1))
+  (ldr imm0 (:@ b2 imm1))
+  (ands imm2 imm0 imm2)  
+  (add imm1 imm1 (:$ 4))
+  (bne @true)
+  (subs count count (:$ 4))
+  (bgt  @loop)
+  (mov arg_z (:$ arm::nil-value))
+  (bx lr)
+  @true
+  (mov arg_z (:$ arm::nil-value))
+  (add arg_z arg_z (:$ arm::t-offset))
+  (bx lr))
+
+;;; dest[idx] <- (lognot src[idx])
+(defarmlapfunction %bignum-lognot ((idx arg_x) (src arg_y) (dest arg_z))
+  (add imm1 idx (:$ arm::misc-data-offset))
+  (ldr imm0 (:@ src imm1))
+  (mvn imm0 imm0)
+  (str imm0 (:@ dest imm1))
+  (bx lr))
+
+;;; dest[idx] <- (logand x[idx] y[idx])
+(defarmlapfunction %bignum-logand ((idx 0) (x arg_x) (y arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (add imm1 temp0 (:$ arm::misc-data-offset))
+  (ldr imm0 (:@ x imm1))
+  (ldr imm2 (:@ y imm1))
+  (and imm0 imm0 imm2)
+  (str imm0 (:@ dest imm1))
+  (bx lr))
+
+;;; dest[idx] <- (logandc2 x[idx] y[idx])
+(defarmlapfunction %bignum-logandc2 ((idx 0) (x arg_x) (y arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (add imm1 temp0 (:$ arm::misc-data-offset))
+  (ldr imm0 (:@ x imm1))
+  (ldr imm2 (:@ y imm1))
+  (bic imm0 imm0 imm2)
+  (str imm0 (:@ dest imm1))
+  (bx lr))
+
+;;; dest[idx] <- (logandc1 x[idx] y[idx])
+(defarmlapfunction %bignum-logandc1 ((idx 0) (x arg_x) (y arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (add imm1 temp0 (:$ arm::misc-data-offset))
+  (ldr imm0 (:@ x imm1))
+  (ldr imm2 (:@ y imm1))
+  (bic imm0 imm2 imm0)
+  (str imm0 (:@ dest imm1))
+  (bx lr))
+
+
+
+(defarmlapfunction digit-lognot-move ((index arg_x) (source arg_y) (dest arg_z))
+  (let ((scaled-index imm1))
+    (vref32 imm0 source index scaled-index) ; imm1 has c(index) + data-offset
+    (mvn imm0 imm0)
+    (str imm0 (:@ dest scaled-index))
+    (bx lr)))
+
+; if dest not nil store unboxed result in dest(0), else return boxed result
+(defarmlapfunction fix-digit-logandc2 ((fix arg_x) (big arg_y) (dest arg_z)) ; index 0
+  (let ((w1 imm0)
+        (w2 imm1))
+    (unbox-fixnum  w1 fix)
+    (ldr w2 (:@ big (:$ arm::misc-data-offset)))
+    (cmp dest 'nil)
+    (bic w1 w1 w2)
+    (bne @store)
+    (box-fixnum arg_z w1)
+    (bx lr)
+    @store
+    (str w1 (:@ dest  (:$ arm::misc-data-offset)))
+    (bx lr)))
+
+
+
+(defarmlapfunction fix-digit-logand ((fix arg_x) (big arg_y) (dest arg_z)) ; index 0
+  (let ((w1 imm0)
+        (w2 imm1))
+    (unbox-fixnum  w1 fix)
+    (ldr w2 (:@ big (:$ arm::misc-data-offset)))
+    (cmp dest 'nil)
+    (and w1 w1 w2)
+    (bne @store)
+    (box-fixnum arg_z w1)
+    (bx lr)
+    @store
+    (str w1 (:@ dest  (:$ arm::misc-data-offset)))
+    (bx lr)))
+
+
+
+(defarmlapfunction fix-digit-logandc1 ((fix arg_x) (big arg_y) (dest arg_z)) ; index 0
+  (let ((w1 imm0)
+        (w2 imm1))
+    (unbox-fixnum  w1 fix)
+    (ldr w2 (:@ big (:$ arm::misc-data-offset)))
+    (cmp dest 'nil)
+    (bic w1 w2 w1)
+    (bne @store)
+    (box-fixnum arg_z w1)
+    (bx lr)
+    @store
+    (str w1 (:@ dest  (:$ arm::misc-data-offset)))
+    (bx lr)))
+
+;;; dest[idx] <- (logior x[idx] y[idx])
+(defarmlapfunction %bignum-logior ((idx 0) (x arg_x) (y arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (add imm1 temp0 (:$ arm::misc-data-offset))
+  (ldr imm0 (:@ x imm1))
+  (ldr imm2 (:@ y imm1))
+  (orr imm0 imm0 imm2)
+  (str imm0 (:@ dest imm1))
+  (bx lr))
+
+;;; dest[idx] <- (logxor x[idx] y[idx])
+(defarmlapfunction %bignum-logxor ((idx 0) (x arg_x) (y arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (add imm1 temp0 (:$ arm::misc-data-offset))
+  (ldr imm0 (:@ x imm1))
+  (ldr imm2 (:@ y imm1))
+  (eor imm0 imm0 imm2)
+  (str imm0 (:@ dest imm1))
+  (bx lr))
+
+
+
+(defarmlapfunction bignum-xor-loop ((count 0) (b1 arg_x) (b2 arg_y) (dest arg_z))
+  (ldr temp0 (:@ vsp (:$ count)))
+  (mov imm1 (:$ arm::misc-data-offset))
+  @loop
+  (ldr imm2 (:@ b1 imm1))
+  (ldr imm0 (:@ b2 imm1))
+  (eor imm2 imm0 imm2)
+  (subs temp0 temp0 (:$ 4))
+  (str imm2 (:@ dest imm1))
+  (add imm1 imm1 (:$ 4))
+  (bgt @loop)
+  @out
+  (add vsp vsp (:$ 4))
+  (bx lr))
+
+#+nomore
+(defarmlapfunction try-guess-loop-1 ((guess-h 8)(guess-l 4)(len-y 0)
+                                     (xidx arg_x) (xptr arg_y) (yptr arg_z))
+  (let ((guess imm0)
+        (carry imm1)
+        (y imm2)
+        (x imm2)
+        (prod-l imm3)
+        (prod-h imm4)
+        (tem imm4)
+        (yidx temp0)
+        (end-y temp1)
+        (carry-bit temp2))
+    (ldr x vsp (:$ guess-h))
+    (ldr tem vsp (:$ guess-l))
+    (compose-digit guess x tem)
+    (ldr end-y vsp (:$ len-y))
+    (li yidx 0)
+    (li carry 0) 
+    (li carry-bit '1)
+    @loop
+    ; multiply guess by ydigit, add carry to lo, hi is new carry
+    ; then get an xdigit subtract prod-lo from it and store result in x (remember carry)
+    (addi tem yidx arm::misc-data-offset)   ; get yidx
+    (ldr y (:@ yptr tem))
+    (mullw prod-l guess y)
+    (mulhwu prod-h guess y)    
+    (addc prod-l prod-l carry) 
+    (adde carry prod-h rzero)
+    ; get back saved carry
+    (li tem '-1)
+    (addc tem carry-bit tem)
+    (addi tem xidx arm::misc-data-offset)
+    (ldr x (:@ xptr tem))    
+    (subfe x prod-l x)        
+    (str x (:@ xptr tem))
+    ; save carry
+    (adde prod-l rzero rzero)
+    (box-fixnum carry-bit prod-l)
+    (addi yidx yidx '1)
+    (cmpw yidx end-y)
+    (addi xidx xidx '1)
+    (blt @loop)
+    ; finally subtract carry from last x digit
+    @done
+    (li prod-l '-1)  ; get back saved carry again - box clobbered it?
+    (addc prod-l carry-bit prod-l)
+    (addi tem xidx arm::misc-data-offset) ; maybe still there - nope
+    (ldr x (:@ xptr tem))
+    (subfe x carry x)
+    (str x (:@ xptr tem))
+    (add vsp vsp (:$ 12))
+    (bx lr)))
+
+;; x0 is at index, x1 at index-1, x2 at index-2
+;; y1 is at index, y2 at index-1
+;; this doesnt help much
+#+notyet
+(defarmlapfunction truncate-guess-loop ((guess-h 8)(guess-l 4)(x 0)
+                                        (xidx arg_x)(yptr arg_y) (yidx arg_z))
+  (let ((guess imm0)
+        (y1 imm1)
+        (y2 imm1)
+        (gy1-lo imm2) ; look out below
+        (gy1-hi imm2)
+        (gy2-lo imm2)
+        (gy2-hi imm2)
+        (xptr temp0)
+        (m imm3)
+        (tem imm4)
+        (y1-idx 28)
+        (y2-idx 24)
+        (x0-idx 20)
+        (x1-idx 16)
+        (x2-idx 12))
+    (stru -32  (:$ tsp)) tsp
+    (str tsp tsp  (:$ 4))
+    (ldr y1 vsp (:$ guess-h))
+    (ldr tem vsp (:$ guess-l))
+    (compose-digit guess y1 tem)
+    (addi tem yidx arm::misc-data-offset)
+    (ldr y1 (:@ yptr tem))
+    (str y1 tsp  (:$ y1-idx))
+    (subi tem tem 4)
+    (ldr y2 (:@ yptr tem))
+    (str y2 tsp  (:$ y2-idx))
+    (ldr xptr vsp (:$ x))
+    (addi tem xidx arm::misc-data-offset)
+    (ldr y1 (:@ xptr tem)) ; its x0
+    (str y1 tsp  (:$ x0-idx))
+    (subi tem tem 4)
+    (ldr y1 (:@ xptr tem))
+    (str y1 tsp  (:$ x1-idx))
+    (subi tem tem 4)
+    (ldr y1 (:@ xptr tem))
+    (str y1 tsp  (:$ x2-idx))
+    @loop
+    (ldr y1 tsp (:$ y1-idx))     ; get y1
+    (mullw gy1-lo guess y1)
+    (ldr m tsp (:$ x1-idx))      ; get x1
+    (subc m m gy1-lo)      ; x1 - gy1-lo => m
+    (mulhwu gy1-hi guess y1)
+    (ldr tem tsp (:$ x0-idx))    ; get x0
+    (subfe. tem gy1-hi tem)      ; - val not used just cr
+    (ldr y2 tsp (:$ y2-idx))     ; get y2
+    (mulhwu gy2-hi guess y2)   ; does it pay to do this now even tho may not need?
+    (bne @done)
+    (cmpl :cr0 gy2-hi m)       ; if > or = and foo then more - L means logical means unsigned
+    (blt @done)           ; if < done
+    (bne @more)           ; if = test lo
+    (mullw gy2-lo guess y2)
+    (ldr tem tsp (:$ x2-idx)) ; get x2
+    (cmpl :cr0 gy2-lo tem)
+    (ble @done)
+    @more
+    (subi guess guess 1)
+    (b @loop)
+    @done
+    (digit-h temp0 guess)
+    (vpush temp0)
+    (digit-l temp0 guess)
+    (vpush temp0)
+    (add temp0 vsp (:$ 20))
+    (ldr tsp tsp (:$ 0))
+    (set-nargs 2)
+    (ba .spvalues)))
+
+(defarmlapfunction normalize-bignum-loop ((sign arg_x)(res arg_y)(len arg_z))
+  (let ((idx imm0)
+        (usign imm1)
+        (val imm2))      
+    (unbox-fixnum usign sign)
+    (cmp len '0)
+    (add idx len (:$ (- arm::misc-data-offset 4))  )
+    (bxeq lr) ; huh - can this ever happen?
+    @loop
+    (ldr val (:@ res idx))
+    (cmp  val usign)    
+    (sub idx idx '1)
+    (bne @neq)    
+    (subs len len '1)
+    (bgt @loop)
+    ; fall through - its all sign - return 1
+    (mov arg_z '1)
+    (bx lr)
+    @neq
+    (and usign usign (:$ #x80000000))
+    (and val val (:$ #x80000000))
+    (cmp usign val)  ; is hi bit = sign, if so then done   
+    (addne len len '1) ; if not, need 1 more
+    (bx lr)))
+
+#+notyet
+(defarmlapfunction %normalize-bignum-2 ((fixp arg_y)(res arg_z))
+  (let ((idx imm0)
+        (usign imm1)
+        (val imm2)
+        (len arg_x)
+        (oldlen temp0))
+    (ldr imm4 res (:$ (- arm::fulltag-misc)))
+    (header-length len imm4)
+    (cmpwi len 0)
+    (mr oldlen len)
+    (addi idx len (- arm::misc-data-offset 4))  
+    (beqlr) ; huh - can this ever happen?
+    (ldr val (:@ res idx)) ; high order word
+    (srawi usign val 31) ; get sign
+    @loop
+    (ldr val (:@ res idx))
+    (cmpw  val usign)    
+    (subi idx idx '1)
+    (bne @neq)    
+    (subic. len len '1)
+    (bgt @loop)
+    ; fall through - its all sign - return 1
+    (li len '1)
+    (rlwinm usign usign 0 0 0) ; hi bit
+    (b @more)
+    @neq
+    (rlwinm usign usign 0 0 0) ; hi bit
+    (rlwinm val val 0 0 0)
+    (cmpw usign val)  ; is hi bit = sign, if so then done   
+    (beq @more)
+    (addi len len '1) ; if not, need 1 more
+    (b @big)
+    @more
+    (cmpwi :cr1 fixp arm::nil-value)
+    (cmpwi len '1)
+    (beq :cr1 @big)  ; dont return fixnum
+    (bgt @big)
+    ;; stuff for maybe fixnum
+    ;(dbg t)
+    (ldr val res (:$ arm::misc-data-offset))
+    (rlwinm imm4 val 0 0 2) ; hi 3 bits same? - we assume fixnumshift is 2
+    (srawi usign usign 2)
+    (cmpw usign imm4)
+    (bne @big)    
+    (box-fixnum arg_z val)
+    (bx lr)
+    @big
+    (cmpw oldlen len)
+    (beqlr) ; same length - done
+    (li imm4 arm::subtag-bignum) ; set new length
+    (rlwimi imm4 len (- arm::num-subtag-bits arm::fixnumshift) 0 (- 31 arm::num-subtag-bits))
+    (str imm4 res  (:$ arm::misc-header-offset))
+    ; 0 to tail if negative
+    (cmpwi usign 0)
+    (beqlr) 
+     ; zero from len inclusive to oldlen exclusive
+    ;(dbg t)
+    (addi idx len arm::misc-data-offset)
+    @loop2
+    (str rzero (:@ idx res))
+    (addi len len '1)
+    (cmpw len oldlen)
+    (addi idx idx '1)
+    (blt @loop2)
+    (bx lr)))
+
+(defarmlapfunction %count-digit-leading-zeros ((high arg_y) (low arg_z))
+  (compose-digit imm0 high low)
+  (clz imm0 imm0)
+  (box-fixnum arg_z imm0)
+  (bx lr))
+
+(defarmlapfunction %count-digit-trailing-zeros ((high arg_y) (low arg_z))
+  (compose-digit imm0 high low)
+  (rsb  imm1 imm0 (:$ 0))
+  (and imm0 imm0 imm1)
+  (clz imm0 imm0)
+  (rsb imm0 imm0 (:$ 31))
+  (box-fixnum arg_z imm0)
+  (bx lr))
+
+
+(defarmlapfunction %bignum-count-trailing-zero-bits ((bignum arg_z))
+  (let ((ndigits arg_x)
+	(nbits arg_y)
+	(digit imm0)
+	(ptr imm1))
+    (mov ptr (:$ arm::misc-data-offset))
+    (mov ndigits '-32)
+    @next
+    (ldr digit (:@ bignum ptr))
+    (cmp digit (:$ 0))
+    (add ptr ptr (:$ 4))
+    (add ndigits ndigits '32)
+    (beq @next)
+    (rsb ptr digit (:$ 0))
+    (and digit digit ptr)
+    (clz digit digit)
+    (rsb digit digit (:$ 31))
+    (box-fixnum nbits digit)
+    (add arg_z nbits ndigits)
+    (bx lr)))
+
+
+(defarmlapfunction %bignum-trim-leading-zeros ((bignum arg_x)
+					       (start arg_y)
+					       (len arg_z))
+  (add imm1 start len)
+  (add imm1 imm1 (:$ (- arm::misc-data-offset 4)))
+  @loop
+  (ldr imm0 (:@ bignum imm1))
+  (cmp imm0 (:$ 0))
+  (add imm1 imm1 (:$ -4))
+  (bxne lr)
+  (subs len len '-1)
+  (bne @loop)
+  (bx lr))
+  
+;;; Set length of bignum to new-len (zeroing out any trailing words between
+;;; the old length and the new.
+(defarmlapfunction %shrink-bignum ((new-len arg_y) (bignum arg_z))
+  (let ((old-len temp0)
+        (rzero temp1)
+	(old-idx imm0)
+	(new-idx imm2)
+	(header imm1))
+    (getvheader header bignum)
+    (header-length old-len header)
+    (mov rzero (:$ 0))
+    (cmp old-len new-len)
+    (add old-idx old-len (:$ arm::misc-data-offset))
+    (add new-idx new-len (:$ arm::misc-data-offset))
+    (bxeq lr)
+    @loop
+    (sub old-idx old-idx (:$ 4))
+    (cmp old-idx new-idx)
+    (str rzero (:@ bignum old-idx))
+    (bne @loop)
+    (mov header (:lsl new-len (:$ (- arm::num-subtag-bits arm::fixnumshift))))
+    (orr header header (:$ arm::subtag-bignum))
+    (str header (:@ bignum  (:$ arm::misc-header-offset)))
+    (bx lr)))
+    
+
+; End of arm-bignum.lisp
Index: /branches/arm/level-0/ARM/arm-float.lisp
===================================================================
--- /branches/arm/level-0/ARM/arm-float.lisp	(revision 13805)
+++ /branches/arm/level-0/ARM/arm-float.lisp	(revision 13805)
@@ -0,0 +1,600 @@
+;;;-*- Mode: Lisp; Package: CCL -*-
+;;;
+;;;   Copyright (C) 2010 Clozure Associates
+;;;   This file is part of Clozure CL.  
+;;;
+;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with Clozure CL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+(in-package "CCL")
+
+(eval-when (:compile-toplevel :execute)
+  (require "NUMBER-MACROS")
+  (require :number-case-macro))
+
+
+;;; make a float from hi - high 24 bits mantissa (ignore implied higher bit)
+;;;                   lo -  low 28 bits mantissa
+;;;                   exp  - take low 11 bits
+;;;                   sign - sign(sign) => result
+;;; hi result - 1 bit sign: 11 bits exp: 20 hi bits of hi arg
+;;; lo result - 4 lo bits of hi arg: 28 lo bits of lo arg
+;;; no error checks, no tweaks, no nuthin 
+
+#+later
+(defarmlapfunction %make-float-from-fixnums ((float 4)(hi 0) (lo arg_x) (exp arg_y) (sign arg_z))
+  (rlwinm imm0 sign 0 0 0)  ; just leave sign bit 
+  (rlwimi imm0 exp (- 20 arm::fixnumshift)  1 11) ;  exp left 20 right 2 keep 11 bits
+  (ldr imm1 (:@ vsp (:$ hi)))
+  (srawi imm1 imm1 arm::fixnumshift)   ; fold into below? nah keep for later
+  (rlwimi imm0 imm1 (- 32 4) 12 31)   ; right 4 - keep  20 - stuff into hi result
+  (rlwinm imm1 imm1 28 0 3)  ; hi goes left 28 - keep 4 hi bits
+  (rlwimi imm1 lo (- 32 arm::fixnumshift) 4 31) ; stuff in 28 bits of lo
+  (ldr temp0 (:@ vsp (:$ float)))         ; the float
+  (stw imm0 arm::double-float.value temp0)
+  (stw imm1 arm::double-float.val-low temp0)
+  (la vsp 8 vsp)
+  (blr))
+
+
+#+later
+(defarmlapfunction %make-short-float-from-fixnums ((float 0) (sig arg_x) (exp arg_y) (sign arg_z))
+  (unbox-fixnum imm0 sig)
+  (rlwimi imm0 exp (- 29 8) 1 8)
+  (inslwi imm0 sign 1 0)
+  (vpop arg_z)
+  (stw imm0 arm::single-float.value arg_z)
+  (blr))
+
+
+(defarmlapfunction %%double-float-abs! ((n arg_y)(val arg_z))
+  (get-double-float d0 n)
+  (fabsd d1 d0)
+  (put-double-float d1 val)
+  (bx lr))
+
+(defarmlapfunction %%short-float-abs! ((n arg_y) (val arg_z))
+  (get-single-float s1 n imm0)
+  (fabss s0 s1)
+  (put-single-float s0 val imm0)
+  (bx lr))
+
+
+
+(defarmlapfunction %double-float-negate! ((src arg_y) (res arg_z))
+  (get-double-float d0 src)
+  (fnegd d1 d0)
+  (put-double-float d1 res)
+  (bx lr))
+
+(defarmlapfunction %short-float-negate! ((src arg_y) (res arg_z))
+  (get-single-float s0 src imm0)
+  (fnegs s1 s0)
+  (put-single-float s1 res imm0)
+  (bx lr))
+
+
+
+
+;;; rets hi (25 bits) lo (28 bits) exp sign
+#+later
+(defarmlapfunction %integer-decode-double-float ((n arg_z))
+  (ldr imm0  (:@ n (:$ arm::double-float.value)))
+  (rlwinm imm1 imm0 (+ 1 arm::fixnumshift) (- 32 arm::fixnumshift 1) ; sign boxed
+          				   (- 32 arm::fixnumshift 1))
+  (add imm1 imm1 imm1)  ; imm1 = (fixnum 2) (neg) or 0 (pos)
+  (subfic temp0 imm1 '1)  ; sign boxed
+  (rlwinm. imm2 imm0 (- 32 20)  21  31)   ; right 20, keep 11 bits exp - test for 0
+  ;(subi imm2 imm2 (+ 53 1022))            ; unbias and scale
+  (slwi imm2 imm2 arm::fixnumshift)      ; box
+  (mr temp1 imm2)                        ; boxed unbiased exponent
+  (rlwinm imm0 imm0 12  0 19)            ; 20 bits of hi float left 12
+  (beq @denorm)                          ; cr set way back
+  (addi imm0 imm0 1)                     ;  add implied 1
+  @denorm
+  (rlwinm imm0 imm0 (+ (- 32 12) 4 arm::fixnumshift) 0 31)
+  (ldr imm1 (:@ n (:$ arm::double-float.val-low))) ; 
+  (rlwimi imm0 imm1 (+ 4 arm::fixnumshift)
+                    (1+ (- 31 4 arm::fixnumshift))
+                    (- 31 arm::fixnumshift))  ; high 4 bits in fixnum pos
+  (rlwinm imm1 imm1 (- 4 arm::fixnumshift) 
+                    (- 4 arm::fixnumshift)
+                    (- 31 arm::fixnum-shift)) ; 28 bits  thats 2 2 29
+  (vpush imm0)   ; hi 25 bits of mantissa (includes implied 1)
+  (vpush imm1)   ; lo 28 bits of mantissa
+  (vpush temp1)  ; exp
+  (vpush temp0)  ; sign
+  (set-nargs 4)
+  (la temp0 '4 vsp)
+  (ba .SPvalues))
+
+
+;;; hi is 25 bits lo is 28 bits
+;;; big is 32 lo, 21 hi right justified
+
+#+later
+(defarmlapfunction make-big-53 ((hi arg_x)(lo arg_y)(big arg_z))
+  (rlwinm imm0 lo (- 32 arm::fixnumshift) 4 31)
+  (rlwimi imm0 hi (- 32 4 arm::fixnumshift) 0 3)
+  (stw imm0 (+ arm::misc-data-offset 0) big)   ; low goes in 1st wd
+  (rlwinm imm0 hi (- 32 (+ arm::fixnumshift 4)) 11 31)  ; high in second
+  (stw imm0 (+ arm::misc-data-offset 4) big)
+  (bx lr))
+
+
+#+later
+(defarmlapfunction dfloat-significand-zeros ((dfloat arg_z))
+  (ldr imm1 (:@ dfloat (:$ arm::double-float.value)))
+  (rlwinm. imm1 imm1 12 0 19)
+  (cntlzw imm1 imm1)
+  (beq @golo)
+  (box-fixnum arg_z imm1)
+  (bx lr)
+  @golo
+  (ldr imm1 (:@ dfloat (:$ arm::double-float.val-low)))
+  (cntlzw imm1 imm1)
+  (addi imm1 imm1 20)
+  (box-fixnum arg_z imm1)
+  (bx lr))
+
+#+later
+(defarmlapfunction sfloat-significand-zeros ((sfloat arg_z))
+   (ldr imm1 (:@ sfloat (:$ arm::single-float.value)))
+  (rlwinm imm1 imm1 9 0 22)
+  (cntlzw imm1 imm1)
+  (box-fixnum arg_z imm1)
+  (bx lr))
+
+
+
+#+later
+(defarmlapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z))
+  (let ((fl.h 8)
+        (fl.l 12)
+        (sc.h 16)
+        (sc.l 20))
+    (clear-fpu-exceptions)
+    (ldr imm0 (:@ float (:$ arm::double-float.value)))
+    (ldr imm1 (:@ float (:$ arm::double-float.val-low)))
+    (stwu tsp -24 tsp)
+    (stw tsp 4 tsp)
+    (stw imm0 fl.h tsp)
+    (stw imm1 fl.l tsp)
+    (unbox-fixnum imm0 int)
+    ;(addi imm0 imm0 1022)  ; bias exponent - we assume no ovf
+    (slwi imm0 imm0 20)     ; more important - get it in right place
+    (stw imm0 sc.h tsp)
+    (stw rzero sc.l tsp)
+    (lfd fp0 fl.h tsp)
+    (lfd fp1 sc.h tsp)
+    (ldr tsp (:@ tsp (:$ 0)))
+    (fmul fp2 fp0 fp1)
+    (stfd fp2 arm::double-float.value result)
+    (bx lr)))
+
+
+
+#+later
+(defarmlapfunction %%scale-sfloat! ((float arg_x)(int arg_y)(result arg_z))
+  (let ((sc.h 12))
+    (clear-fpu-exceptions)
+    (lfs fp0 arm::single-float.value float)
+    (unbox-fixnum imm0 int)
+    (slwi imm0 imm0 IEEE-single-float-exponent-offset)
+    (stwu tsp -16 tsp)
+    (stw tsp 4 tsp)
+    (stw imm0 sc.h tsp)
+    (lfs fp1 sc.h tsp)
+    (ldr tsp (:@ tsp (:$ 0)))
+    (fmuls fp2 fp0 fp1)
+    (stfs fp2 arm::single-float.value result)
+    (bx lr)))
+                   
+
+
+
+(defarmlapfunction %copy-double-float ((f1 arg_y) (f2 arg_z))
+  (ldrd imm0 (:@ f1 (:$ arm::double-float.value)))
+  (strd imm0 (:@ f2 (:$ arm::double-float.value)))
+  (bx lr))
+                   
+
+
+(defarmlapfunction %copy-short-float ((f1 arg_y) (f2 arg_z))
+  (ldr imm0 (:@ f1 (:$ arm::single-float.value)))
+  (str imm0 (:@ f2 (:$ arm::single-float.value)))
+  (bx lr))
+
+
+(defarmlapfunction %double-float-exp ((n arg_z))
+  (ldr imm1 (:@ n (:$ arm::double-float.val-high)))
+  (mov imm1 (:lsl imm1 (:$ 1)))
+  (mov imm1 (:lsr imm1 (:$ 21)))
+  (box-fixnum arg_z imm1)
+  (bx lr))
+
+
+
+
+(defarmlapfunction set-%double-float-exp ((float arg_y) (exp arg_z))
+  (ldr imm1 (:@ float (:$ arm::double-float.val-high)))
+  (mov imm0 (:$ #xff000000))
+  (orr imm0 imm0 (:$ #x00e00000))
+  (bic imm1 imm1 (:lsr imm0 (:$ 1)))
+  (and imm0 imm0 (:lsl exp (:$ (- 21 arm::fixnumshift))))
+  (orr imm1 imm1 (:lsr imm0 (:$ 1)))
+  (str imm1 (:@ float (:$ arm::double-float.val-high))) ; hdr - tag = 8 - 2
+  (bx lr))
+
+
+
+
+(defarmlapfunction %short-float-exp ((n arg_z))
+  (ldr imm1 (:@ n (:$ arm::single-float.value)))
+  (mov arg_z (:$ (ash #xff arm::fixnumshift)))
+  (and arg_z arg_z (:lsr imm1 (:$ (- 23 arm::fixnumshift))))
+  (bx lr))
+
+
+
+
+(defarmlapfunction set-%short-float-exp ((float arg_y) (exp arg_z))
+  (ldr imm1 (:@ float (:$ arm::single-float.value)))
+  (mov imm0 (:$ #xff000000))
+  (bic imm1 imm1 (:lsr imm0 (:$ 1)))
+  (and imm0 imm0 (:lsl exp (:$ (- 24 arm::fixnumshift))))
+  (orr imm1 imm1 (:lsr imm0 (:$ 1)))
+  (str imm1 (:@ float (:$ arm::single-float.value)))
+  (bx lr))
+
+  
+(defarmlapfunction %short-float->double-float ((src arg_y) (result arg_z))
+  (get-single-float s0 src imm0)
+  (fcvtds d1 s0)
+  (put-double-float d1 result)
+  (bx lr))
+
+
+(defarmlapfunction %double-float->short-float ((src arg_y) (result arg_z))
+  ;(clear-fpu-exceptions)
+  (get-double-float d0 src)
+  (fcvtsd s1 d0)
+  (put-single-float s1 result imm0)
+  (bx lr))
+
+
+  
+
+
+
+(defarmlapfunction %int-to-sfloat! ((int arg_y) (sfloat arg_z))
+  (unbox-fixnum imm0 int)
+  (fmsr s0 imm0)
+  (fsitos s1 s0)
+  (put-single-float s1 sfloat imm0)
+  (bx lr))
+
+
+  
+
+(defarmlapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z))
+  (unbox-fixnum imm0 int)
+  (fmsr s0 imm0)
+  (fsitod d1 s0)
+  (put-double-float d1 dfloat)
+  (bx lr))
+
+
+
+
+#+notyet
+(progn
+; Manipulating the FPSCR.
+; This  returns the bottom 8 bits of the FPSCR
+(defarmlapfunction %get-fpscr-control ()
+  (mffs fp0)
+  (stfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
+  (lbz imm0 (+ arm::tcr.lisp-fpscr-high 7) arm::rcontext)
+  (box-fixnum arg_z imm0)
+  (bx lr))
+
+; Returns the high 24 bits of the FPSCR
+(defarmlapfunction %get-fpscr-status ()
+  (mffs fp0)
+  (stfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
+  (ldr imm0 (:@ tsp (:$ arm::tcr.lisp-fpscr-low)))
+  (clrrwi imm0 imm0 8)
+  (srwi arg_z imm0 (- 8 arm::fixnumshift))
+  (bx lr))
+
+; Set the high 24 bits of the FPSCR; leave the low 8 unchanged
+(defarmlapfunction %set-fpscr-status ((new arg_z))
+  (slwi imm0 new (- 8 arm::fixnumshift))
+  (stw imm0 arm::tcr.lisp-fpscr-low arm::rcontext)
+  (lfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
+  (mtfsf #xfc fp0)                      ; set status fields [0-5]
+  (bx lr))
+
+; Set the low 8 bits of the FPSCR.  Zero the upper 24 bits
+(defarmlapfunction %set-fpscr-control ((new arg_z))
+  (unbox-fixnum imm0 new)
+  (clrlwi imm0 imm0 24)                 ; ensure that "status" fields are clear
+  (stw imm0 arm::tcr.lisp-fpscr-low arm::rcontext)
+  (lfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
+  (mtfsf #xff fp0)                      ; set all fields [0-7]
+  (bx lr))
+
+
+(defarmlapfunction %ffi-exception-status ()
+  (ldr imm0  arm::tcr.ffi-exception arm::rcontext)
+  (mtcrf #xfc imm0)
+  (mcrfs :cr6 :cr6)
+  (mcrfs :cr7 :cr7)
+  (crand ppc::fpscr-fex-bit ppc::fpscr-oe-bit ppc::fpscr-ox-bit)
+  (bt ppc::fpscr-fex-bit @set)
+  (crand ppc::fpscr-fex-bit ppc::fpscr-ve-bit ppc::fpscr-vx-bit)
+  (bt ppc::fpscr-fex-bit @set)
+  (crand ppc::fpscr-fex-bit ppc::fpscr-ue-bit ppc::fpscr-ux-bit)
+  (bt ppc::fpscr-fex-bit @set)
+  (crand ppc::fpscr-fex-bit ppc::fpscr-ze-bit ppc::fpscr-zx-bit)
+  (bt ppc::fpscr-fex-bit @set)
+  (crand ppc::fpscr-fex-bit ppc::fpscr-xe-bit ppc::fpscr-xx-bit)
+  (bf ppc::fpscr-fex-bit @ret)
+  @set
+  (oris imm0 imm0 #xc000)
+  @ret
+  (srwi arg_z imm0 (- 8 arm::fixnumshift))
+  (bx lr))
+  
+
+; See if the binary double-float operation OP set any enabled
+; exception bits in the fpscr
+(defun %df-check-exception-2 (operation op0 op1 fp-status)
+  (declare (type (unsigned-byte 24) fp-status))
+  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
+    (%set-fpscr-status 0)
+    ;; Ensure that operands are heap-consed
+    (%fp-error-from-status fp-status 
+			   (%get-fpscr-control)
+			   operation 
+			   (%copy-double-float op0 (%make-dfloat)) 
+			   (%copy-double-float op1 (%make-dfloat)))))
+
+(defun %sf-check-exception-2 (operation op0 op1 fp-status)
+  (declare (type (unsigned-byte 24) fp-status))
+  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
+    (%set-fpscr-status 0)
+    ;; Ensure that operands are heap-consed
+    (%fp-error-from-status fp-status 
+			   (%get-fpscr-control)
+			   operation
+			   
+			   (%copy-short-float op0 (%make-sfloat))
+			   
+			   (%copy-short-float op1 (%make-sfloat)))))
+
+(defun %df-check-exception-1 (operation op0 fp-status)
+  (declare (fixnum fp-status))
+  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
+    (%set-fpscr-status 0)
+    ;; Ensure that operands are heap-consed
+    (%fp-error-from-status fp-status 
+                              (%get-fpscr-control)
+                              operation 
+                              (%copy-double-float op0 (%make-dfloat)))))
+
+(defun %sf-check-exception-1 (operation op0 fp-status)
+  (declare (type (unsigned-byte 24) fp-status))
+  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
+    (%set-fpscr-status 0)
+					; Ensure that operands are heap-consed
+    (%fp-error-from-status fp-status 
+			   (%get-fpscr-control)
+			   operation
+			   
+			   (%copy-short-float op0 (%make-sfloat)))))
+
+
+(defun fp-condition-from-fpscr (status-bits control-bits)
+  (declare (fixnum status-bits control-bits))
+  (cond 
+   ((and (logbitp (- 23 ppc::fpscr-vx-bit) status-bits)
+         (logbitp (- 31 ppc::fpscr-ve-bit) control-bits))
+    'floating-point-invalid-operation)
+   ((and (logbitp (- 23 ppc::fpscr-ox-bit) status-bits)
+         (logbitp (- 31 ppc::fpscr-oe-bit) control-bits))
+    'floating-point-overflow)
+   ((and (logbitp (- 23 ppc::fpscr-ux-bit) status-bits)
+         (logbitp (- 31 ppc::fpscr-ue-bit) control-bits))
+    'floating-point-underflow)
+   ((and (logbitp (- 23 ppc::fpscr-zx-bit) status-bits)
+         (logbitp (- 31 ppc::fpscr-ze-bit) control-bits))
+    'division-by-zero)
+   ((and (logbitp (- 23 ppc::fpscr-xx-bit) status-bits)
+         (logbitp (- 31 ppc::fpscr-xe-bit) control-bits))
+    'floating-point-inexact)))
+
+;;; This assumes that the FEX and one of {VX OX UX ZX XX} is set.
+(defun %fp-error-from-status (status-bits control-bits operation &rest operands)
+  (declare (type (unsigned-byte 16) status-bits))
+  (case operation
+    (sqrt (setq operands (cdr operands))))
+  (let* ((condition-class (fp-condition-from-fpscr status-bits control-bits)))
+    (if condition-class
+      (error (make-instance condition-class
+               :operation operation
+               :operands operands)))))
+
+(defun fp-minor-opcode-operation (minor-opcode)
+  (case minor-opcode
+    (25 '*)
+    (18 '/)
+    (20 '-)
+    (21 '+)
+    (22 'sqrt)
+    (t 'unknown)))
+
+);#+notyet
+
+;;; Don't we already have about 20 versions of this ?
+(defarmlapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z))
+  (ldr imm0 (:@ ptr (:$ arm::macptr.address)))
+  (unbox-fixnum imm1 byte-offset)
+  (ldrd imm0  (:@ imm0 imm1))
+  (strd imm0 (:@ dest (:$ arm::double-float.value)))
+  (bx lr))
+
+
+#+notyet
+(progn
+(defvar *rounding-mode-alist*
+  '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3)))
+
+(defun get-fpu-mode (&optional (mode nil mode-p))
+  (let* ((flags (%get-fpscr-control)))
+    (declare (type (unsigned-byte 8) flags))
+    (if mode-p
+      (ecase mode
+        (:rounding-mode (car (nth (logand flags 3) *rounding-mode-alist*)))
+        (:overflow (logbitp (- 31 ppc::fpscr-oe-bit) flags))
+        (:underflow (logbitp (- 31 ppc::fpscr-ue-bit) flags))
+        (:division-by-zero (logbitp (- 31 ppc::fpscr-ze-bit) flags))
+        (:invalid (logbitp (- 31 ppc::fpscr-ve-bit) flags))
+        (:inexact (logbitp (- 31 ppc::fpscr-xe-bit) flags)))
+      `(:rounding-mode ,(car (nth (logand flags 3) *rounding-mode-alist*))
+        :overflow ,(logbitp (- 31 ppc::fpscr-oe-bit) flags)
+        :underflow ,(logbitp (- 31 ppc::fpscr-ue-bit) flags)
+        :division-by-zero ,(logbitp (- 31 ppc::fpscr-ze-bit) flags)
+        :invalid ,(logbitp (- 31 ppc::fpscr-ve-bit) flags)
+        :inexact ,(logbitp (- 31 ppc::fpscr-xe-bit) flags)))))
+
+;;; did we document this?
+(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p)
+                          (overflow t overflow-p)
+                          (underflow t underflow-p)
+                          (division-by-zero t zero-p)
+                          (invalid t invalid-p)
+                          (inexact t inexact-p))
+  (let* ((mask (logior (if rounding-p #x03 #x00)
+                       (if invalid-p
+                         (ash 1 (- 31 ppc::fpscr-ve-bit))
+                         #x00)
+                       (if overflow-p
+                         (ash 1 (- 31 ppc::fpscr-oe-bit))
+                         #x00)
+                       (if underflow-p
+                         (ash 1 (- 31 ppc::fpscr-ue-bit))
+                         #x00)
+                       (if zero-p
+                         (ash 1 (- 31 ppc::fpscr-ze-bit))
+                         #x00)
+                       (if inexact-p
+                         (ash 1 (- 31 ppc::fpscr-xe-bit))
+                         #x00)))
+         (new (logior (or (cdr (assoc rounding-mode *rounding-mode-alist*))
+                          (error "Unknown rounding mode: ~s" rounding-mode))
+                      (if invalid (ash 1 (- 31 ppc::fpscr-ve-bit)) 0)
+                      (if overflow (ash 1 (- 31 ppc::fpscr-oe-bit)) 0)
+                      (if underflow (ash 1 (- 31 ppc::fpscr-ue-bit))  0)
+                      (if division-by-zero (ash 1 (- 31 ppc::fpscr-ze-bit)) 0)
+                      (if inexact (ash 1 (- 31 ppc::fpscr-xe-bit)) 0))))
+    (declare (type (unsigned-byte 8) new mask))
+    (%set-fpscr-control (logior (logand new mask)
+                                (logandc2 (%get-fpscr-control) mask)))))
+)
+
+
+;;; Copy a single float pointed at by the macptr in single
+;;; to a double float pointed at by the macptr in double
+
+(defarmlapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z))
+  (check-nargs 2)
+  (macptr-ptr imm0 single)
+  (flds s0 (:@ imm0 (:$ 0)))
+  (fcvtds d1 s0)
+  (macptr-ptr imm0 double)
+  (fstd d1 (:@ imm0 (:$ 0)))
+  (bx lr))
+
+;;; Copy a double float pointed at by the macptr in double
+;;; to a single float pointed at by the macptr in single.
+(defarmlapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z))
+  (check-nargs 2)
+  (macptr-ptr imm0 double)
+  (fldd d0 (:@ imm0 (:$ 0)))
+  (macptr-ptr imm0 single)
+  (fcvtsd s2 d0)
+  (fsts s2 (:@  imm0 (:$ 0)))
+  (bx lr))
+
+
+(defarmlapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z))
+  (check-nargs 2)
+  (macptr-ptr imm0 macptr)
+  (get-double-float d1 src)
+  (fcvtsd s0 d1)
+  (fsts s0 (:@ imm0 (:$ 0)))
+  (bx lr))
+
+
+(defun host-single-float-from-unsigned-byte-32 (u32)
+  (let* ((f (%make-sfloat)))
+    (setf (uvref f arm::single-float.value-cell) u32)
+    f))
+
+
+
+
+
+(defun single-float-bits (f)
+  (uvref f arm::single-float.value-cell))
+
+
+
+(defun double-float-bits (f)
+  (values (uvref f arm::double-float.val-high-cell)
+          (uvref f arm::double-float.val-low-cell)))
+
+(defun double-float-from-bits (high low)
+  (let* ((f (%make-dfloat)))
+    (setf (uvref f arm::double-float.val-high-cell) high
+          (uvref f arm::double-float.val-low-cell) low)
+    f))
+
+(defarmlapfunction %double-float-sign ((n arg_z))
+  (ldr imm0 (:@ n (:$ arm::double-float.val-high)))
+  (cmp imm0 '($ 0))
+  (mov arg_z 'nil)
+  (addlt arg_z arg_z (:$ arm::t-offset))
+  (bx lr))
+
+(defarmlapfunction %short-float-sign ((n arg_z))
+  (ldr imm0 (:@ n (:$ arm::single-float.value)))
+  (cmp imm0 '($ 0))
+  (mov arg_z 'nil)
+  (addlt arg_z arg_z (:$ arm::t-offset))
+  (bx lr))
+
+(defarmlapfunction %single-float-sqrt! ((src arg_y) (dest arg_z))
+  (get-single-float s0 src imm0)
+  (fsqrts s1 s0)
+  (put-single-float s1 dest imm0)
+  (bx lr))
+
+
+
+(defarmlapfunction %double-float-sqrt! ((src arg_y) (dest arg_z))
+  (get-double-float d0 src)
+  (fsqrtd d1 d0)
+  (put-double-float d1 dest)
+  (bx lr))
+
+