Index: /branches/arm/level-0/ARM/arm-array.lisp
===================================================================
--- /branches/arm/level-0/ARM/arm-array.lisp	(revision 13756)
+++ /branches/arm/level-0/ARM/arm-array.lisp	(revision 13756)
@@ -0,0 +1,679 @@
+;;;-*- 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"))
+
+
+;;; Users of this shouldn't make assumptions about return value.
+
+
+(eval-when (:compile-toplevel :execute)
+;;; Assumptions made by %init-misc
+  (assert (and (< arm::max-32-bit-ivector-subtag
+                  arm::max-8-bit-ivector-subtag
+                  arm::max-16-bit-ivector-subtag)
+               (eql arm::max-32-bit-ivector-subtag arm::subtag-simple-base-string)
+               (eql arm::max-16-bit-ivector-subtag arm::subtag-s16-vector)
+               (eql arm::max-8-bit-ivector-subtag 223))))
+
+
+(defarmlapfunction %init-misc ((val arg_y)
+                               (miscobj arg_z))
+  (getvheader imm0 miscobj)
+  (bic temp1 imm0 (:$ arm::subtag-mask))
+  (movs temp1 (:lsr temp1 (:$ (- arm::num-subtag-bits arm::fixnumshift))))
+  (extract-lowbyte imm2 imm0)
+  (extract-fulltag imm1 imm0)
+  (bxeq lr)
+  (cmp imm1 (:$ arm::fulltag-nodeheader))
+  (bne @ivector)
+  (mov imm1 (:$ arm::misc-data-offset))
+  @node-loop
+  (subs temp1 temp1 '1)
+  (str val (:@ miscobj imm1))
+  (add imm1 imm1 '1)
+  (bne @node-loop)
+  (bx lr)
+  @ivector
+  (build-lisp-frame imm0)
+  (mov imm1 (:$ arm::misc-data-offset))
+  (mov imm2 (:lsr imm2 (:$ 3)))
+  (bl @dispatch)
+  (b @u32)                              ;bignum,0
+  (b @u32)                              ;single-float
+  (b @u32)                              ;double-float
+  (b @u32)                              ;macptr
+  (b @u32)                              ;dead-macptr
+  (b @u32)                              ;code-vector, 5
+  (b @bad)
+  (b @bad)
+  (b @bad)
+  (b @bad)
+  (b @bad)
+  (b @bad)
+  (b @bad)
+  (b @bad)
+  (b @bad)
+  (b @bad)
+  (b @bad)
+  (b @bad)
+  (b @bad)
+  (b @bad)
+  (b @single-float-vector)              ;20
+  (b @u32)
+  (b @s32)
+  (b @fixnum)
+  (b @string)
+  (b @u8)
+  (b @s8)
+  (b @string8)
+  (b @u16)
+  (b @s16)
+  (b @double-float-vector)
+  (b @bit-vector)
+  @dispatch
+  (add pc lr (:lsl imm2 (:$ arm::word-shift)))
+  @u32
+  ;; Non-negative fixnum, positive one-digit bignum, two-digit bignum with
+  ;; high word 0.
+  (tst val (:$ #x80000003))
+  (moveq imm0 (:lsr val (:$ arm::fixnumshift)))
+  (beq @word-set-loop)
+  (extract-typecode imm0 val)
+  (cmp imm0 (:$ arm::subtag-bignum))
+  (bne @bad)
+  (getvheader imm0 val)
+  (header-size imm0 imm0)
+  (cmp imm0 (:$ 1))
+  (bne @u32-two-digit)
+  (ldr imm0 (:@ val (:$ arm::misc-data-offset)))
+  (cmp imm0 (:$ 0))
+  (bmi @bad)
+  (b @word-set-loop)
+  @u32-two-digit
+  (cmp imm0 (:$ 2))
+  (ldr imm0 (:@ val (:$ (+ arm::misc-data-offset 4))))
+  (bne @bad)
+  (cmp imm0 (:$ 0))
+  (bne @bad)
+  (b @word-set-loop)
+  @s32
+  ;; A fixnum or a 1-digit bignum.
+  (ands imm0 val (:$ arm::tag-mask))
+  (moveq imm0 (:asr val (:$ arm::fixnumshift)))
+  (beq @word-set-loop)
+  (cmp imm0 (:$ arm::tag-misc))
+  (ldrbeq imm0 (:@ val (:$ arm::misc-subtag-offset)))
+  (cmp imm0 (:$ arm::subtag-bignum))
+  (bne @bad)
+  (getvheader imm0 val)
+  (header-size imm0 imm0)
+  (cmp imm0 (:$ 1))
+  (ldr imm0 (:@ val (:$ arm::misc-data-offset)))
+  (bne @bad)
+  @word-set-loop
+  (subs temp1 temp1 '1)
+  (str imm0 (:@ miscobj imm1))
+  (add imm1 imm1 '1)
+  (bne @word-set-loop)
+  (return-lisp-frame)
+  @string
+  (extract-lowbyte imm0 val)
+  (cmp imm0 (:$ arm::subtag-character))
+  (mov imm0 (:lsr imm0 (:$ arm::charcode-shift)))
+  (beq @word-set-loop)
+  @bad
+  (mov arg_x  '#.$xnotelt)
+  (set-nargs 3)
+  (call-symbol %err-disp)
+  @fixnum
+  (tst val (:$ arm::fixnum-mask))
+  (unbox-fixnum imm0 val)
+  (bne @word-set-loop)
+  (b @bad)
+  @single-float-vector
+  (extract-subtag imm0 val)
+  (cmp imm0 (:$ arm::subtag-single-float-vector))
+  (bne @bad)
+  (ldr imm0 (:@ val (:$ arm::misc-data-offset)))
+  (b @word-set-loop)
+  @u16
+  (mov imm0 (:lsl val (:$ (- 16 arm::fixnumshift))))
+  (mov imm0 (:lsr val (:$ 16)))
+  (cmp val (:lsl imm0 (:$ arm::fixnumshift)))
+  (bne @bad)
+  @set16
+  (orr imm0 imm0 (:lsl imm0 (:$ 16)))
+  (add imm2 temp1 '1)
+  (mov temp1 (:$ (- arm::fixnumone)))
+  (and temp1 temp1 (:lsr imm2 (:$ 1)))
+  (b @word-set-loop)
+  @s16
+  (mov imm0 (:lsl val (:$ (- 16 arm::fixnumshift))))
+  (mov imm0 (:asr val (:$ 16)))
+  (cmp val (:lsl imm0 (:$ arm::fixnumshift)))
+  (bne @bad)
+  (b @set16)
+  @u8
+  (mov imm0 (:lsl val (:$ (- 24 arm::fixnumshift))))
+  (mov imm0 (:lsr val (:$ 24)))
+  (cmp val (:lsl imm0 (:$ arm::fixnumshift)))  
+  (bne @bad)
+  @set8
+  (orr imm0 imm0 (:lsl imm0 (:$ 8)))
+  (orr imm0 imm0 (:lsl imm0 (:$ 16)))
+  (unbox-fixnum imm2 temp1)
+  (add imm2 imm2 (:$ 3))
+  (mov imm2 (:lsr imm2 (:$ 2)))
+  (box-fixnum temp1 imm2)
+  (b @word-set-loop)
+  @s8
+  (mov imm0 (:lsl val (:$ (- 24 arm::fixnumshift))))
+  (mov imm0 (:asr val (:$ 24)))
+  (cmp val (:lsl imm0 (:$ arm::fixnumshift)))  
+  (beq @set8)
+  (b @bad)
+  @string8
+  (extract-lowbyte imm0 val)
+  (cmp imm0 (:$ arm::subtag-character))
+  (mov imm0 (:lsr imm0 (:$ arm::charcode-shift)))
+  (bne @bad)
+  (cmp imm0 (:$ #xff))
+  (bls @set8)
+  (b @bad)
+  @bit-vector
+  (cmp val '1)
+  (moveq imm0 (:$ -1))
+  (movne imm0 (:$ 0))
+  (bhi @bad)
+  (unbox-fixnum imm2 temp1)
+  (add imm2 imm2 (:$ 31))
+  (mov imm2 (:lsr imm2 (:$ 5)))
+  (box-fixnum temp1 imm2)
+  (b @word-set-loop)
+  @double-float-vector
+  (extract-typecode imm0 val)
+  (cmp imm0 (:$ arm::subtag-double-float))
+  (bne @bad)
+  (ldrd imm0 (:@ val (:$ arm::double-float.value)))
+  (mov imm2 (:$ arm::misc-dfloat-offset))
+  @double-float-loop
+  (subs temp1 temp1 '1)
+  (strd imm0 (:@ miscobj imm2))
+  (add imm2 imm2 (:$ 8))
+  (bne @double-float-loop)
+  (return-lisp-frame imm0))
+
+
+
+;;; Make a new vector of size newsize whose subtag matches that of oldv-arg.
+;;; Blast the contents of the old vector into the new one as quickly as
+;;; possible; leave remaining elements of new vector undefined (0).
+;;; Return new-vector.
+(defun %extend-vector (start oldv newsize)
+  (declare (fixnum start))
+  (let* ((new (%alloc-misc newsize (typecode oldv)))
+         (oldsize (uvsize oldv)))
+    (declare (fixnum oldsize))
+    (do* ((i 0 (1+ i))
+          (j start (1+ j)))
+         ((= i oldsize) new)
+      (declare (fixnum i j))
+      (setf (uvref new j) (uvref oldv i)))))
+
+#+later
+(defarmlapfunction %extend-vector ((start-arg arg_x) (oldv-arg arg_y) (newsize arg_z))
+  (let ((oldv save0)
+        (oldsize save1)
+        (oldsubtag save2)
+        (start-offset save3))
+    (save-lisp-context)
+    (:regsave save3 0)
+    (vpush save0)
+    (vpush save1)
+    (vpush save2)
+    (vpush save3)
+    (mov oldv oldv-arg)
+    (mov start-offset start-arg)
+    (getvheader imm0 oldv)
+    (header-length oldsize imm0)
+    (header-subtag[fixnum] oldsubtag imm0)
+    (mov arg_y newsize)
+    (mov arg_z oldsubtag)
+    (bla .SPmisc-alloc)
+    (extrwi imm0 oldsubtag arm::ntagbits (- 32 (+  arm::fixnumshift arm::ntagbits)))
+    (cmpwi cr0 oldsize 0)
+    (cmpwi cr1 imm0 arm::fulltag-nodeheader)
+    (cmpwi cr2 oldsubtag '#.arm::max-32-bit-ivector-subtag)
+    (la imm1 arm::misc-data-offset start-offset)
+    (mov imm3 (:$ arm::misc-data-offset))
+    (beq cr0 @done)
+    (bne cr1 @imm)
+    ;; copy nodes.  New vector is "new", so no memoization required.
+    @node-loop
+    (cmpwi cr0 oldsize '1)
+    (lwzx temp0 oldv imm1)
+    (addi imm1 imm1 4)
+    (subi oldsize oldsize '1)
+    (stwx temp0 arg_z imm3)
+    (addi imm3 imm3 4)
+    (bne cr0 @node-loop)
+    ;;Restore registers.  New vector's been in arg_z all this time.
+    @done
+    (lwz save3 0 vsp)
+    (lwz save2 4 vsp)
+    (lwz save1 8 vsp)
+    (lwz save0 12 vsp)
+    (restore-full-lisp-context)
+    (blr)
+    @imm
+    (unbox-fixnum imm2 oldsize)
+    (unbox-fixnum imm3 start-offset)
+    (mov imm1 (:$ arm::misc-data-offset))
+    (la imm4 arm::misc-data-offset start-offset)
+    (cmpwi cr1 oldsubtag '#.arm::max-8-bit-ivector-subtag)
+    (cmpwi cr0 oldsubtag '#.arm::max-16-bit-ivector-subtag)
+    (ble cr2 @fullword-loop)
+    (cmpwi cr2 oldsubtag '#.arm::subtag-bit-vector)
+    (ble cr1 @8-bit)
+    (ble cr0 @16-bit)
+    (beq cr2 @1-bit)
+    ;; 64-bit (double-float) vectors.  There's a different
+    ;; initial offset, but we're always word-aligned, so that
+    ;; part's easy.
+    (mov imm1 (:$ arm::misc-dfloat-offset))   ; scaled destination pointer
+    (slwi imm2 imm2 1)                  ; twice as many fullwords
+    (slwi imm3 imm3 3)                  ; convert dword count to byte offset
+    (la imm4 arm::misc-dfloat-offset imm3)      ; scaled source pointer
+    (b @fullword-loop)
+    ;; The bitvector case is hard if START-OFFSET isn't on an 8-bit boundary,
+    ;;  and can be turned into the 8-bit case otherwise.
+    ;; The 8-bit case is hard if START-OFFSET isn't on a 16-bit boundary, 
+    ;;  and can be turned into the 16-bit case otherwise.
+    ;; The 16-bit case is hard if START-OFFSET isn't on a 32-bit boundary, 
+    ;;  and can be turned into the 32-bit case otherwise.
+    ;; Hmm.
+    @1-bit
+    (clrlwi. imm0 imm3 (- 32 3))
+    (bne- cr0 @hard-1-bit)
+    (srwi imm3 imm3 3)                  ; bit offset to byte offset
+    (addi imm2 imm2 7)
+    (srwi imm2 imm2 3)                  ; bit count to byte count
+    @8-bit
+    ; If the byte offset's even, copy half as many halfwords
+    (clrlwi. imm0 imm3 (- 32 1))
+    (bne- cr0 @hard-8-bit)
+    (addi imm2 imm2 1)
+    (srwi imm2 imm2 1)                  ; byte count to halfword count
+    (srwi imm3 imm3 1)                  ; byte offset to halfword offset
+    @16-bit
+    ; If the halfword offset's even, copy half as many fullwords
+    (clrlwi. imm0 imm3 (- 32 1))
+    (bne- cr0 @hard-16-bit)
+    (addi imm2 imm2 1)
+    (srwi imm2 imm2 1)                  ; halfword count to fullword count
+    (mov imm1 (:$ arm::misc-data-offset))   
+    @fullword-loop
+    (cmpwi cr0 imm2 1)
+    (lwzx imm0 oldv imm4)
+    (addi imm4 imm4 4)
+    (subi imm2 imm2 1)
+    (stwx imm0 arg_z imm1)
+    (addi imm1 imm1 4)
+    (bne cr0 @fullword-loop)
+    (b @done)
+    ;;; This can just do a uvref/uvset loop.  Cases that can
+    ;;; cons (x32, double-float) have already been dealt with.
+    @hard-1-bit
+    @hard-8-bit
+    @hard-16-bit
+    (let ((newv save4)
+          (outi save5)
+          (oldlen save6))
+      (vpush save4)
+      (vpush save5)
+      (vpush save6)
+      (mov newv arg_z)
+      (sub oldlen oldsize start-offset)
+      (mov outi (:$ 0))
+      @hard-loop
+      (mov arg_y oldv)
+      (mov arg_z start-offset)
+      (bla .SPmisc-ref)
+      (mov arg_x newv)
+      (mov arg_y outi)
+      (bla .SPmisc-set)
+      (la outi '1 outi)
+      (cmpw cr0 outi oldlen)
+      (la start-offset '1 start-offset)
+      (bne @hard-loop)
+      (mov arg_z newv)
+      (vpop save6)
+      (vpop save5)
+      (vpop save4)
+      (b @done))))
+
+;;; argument is a vector header or an array header.  Or else.
+(defarmlapfunction %array-header-data-and-offset ((a arg_z))
+  (let ((offset arg_y)
+        (disp arg_x)
+        (temp temp0))
+    (mov offset (:$ 0))
+    (mov temp a)
+    @loop
+    (ldr a (:@ temp (:$ target::arrayH.data-vector)))
+    (ldrb imm0 (:@ a (:$ target::misc-subtag-offset)))
+    (cmp imm0 (:$ target::subtag-vectorH))
+    (ldr disp (:@ temp (:$ target::arrayH.displacement)))
+    (mov temp a)
+    (add offset offset disp)
+    (ble  @loop)
+    (mov temp0 vsp)
+    (vpush1 a)
+    (vpush1 offset)
+    (set-nargs 2)
+    (ba .SPvalues)))
+
+(defarmlapfunction %boole-clr ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (mov imm0 (:$ 0))
+  (b @test)
+  @loop
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-set ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (mov imm0 (:$ -1))
+  (b @test)
+  @loop
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-1 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b0 imm2))
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-2 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b1 imm2))
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-c1 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b0 imm2))
+  (mvn imm0 imm0)
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-c2 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b1 imm2))
+  (mvn imm0 imm0)
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-and ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b0 imm2))
+  (ldr imm1 (:@ b1 imm2))
+  (and imm0 imm0 imm1)
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-ior ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b0 imm2))
+  (ldr imm1 (:@ b1 imm2))
+  (orr imm0 imm0 imm1)
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-xor ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b0 imm2))
+  (ldr imm1 (:@ b1 imm2))
+  (eor imm0 imm0 imm1)
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-eqv ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b0 imm2))
+  (ldr imm1 (:@ b1 imm2))
+  (eor imm0 imm0 imm1)
+  (mvn imm0 imm0)
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-nand ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b0 imm2))
+  (ldr imm1 (:@ b1 imm2))
+  (and imm0 imm0 imm1)
+  (mvn imm0 imm0)
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-nor ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b0 imm2))
+  (ldr imm1 (:@ b1 imm2))
+  (orr imm0 imm0 imm1)
+  (mvn imm0 imm0)
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-andc1 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b0 imm2))
+  (ldr imm1 (:@ b1 imm2))
+  (bic imm0 imm1 imm0)
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-andc2 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b0 imm2))
+  (ldr imm1 (:@ b1 imm2))
+  (bic imm0 imm0 imm1)
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-orc1 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b0 imm2))
+  (ldr imm1 (:@ b1 imm2))
+  (mvn imm0 imm0)
+  (orr imm0 imm0 imm1)
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defarmlapfunction %boole-orc2 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (vpop1 temp0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  (b @test)
+  @loop
+  (ldr imm0 (:@ b0 imm2))
+  (ldr imm1 (:@ b1 imm2))
+  (mvn imm1 imm1)
+  (orr imm0 imm0 imm1)
+  (str imm0 (:@ dest imm2))
+  (add imm2 imm2 (:$ 4))
+  @test
+  (subs temp0 temp0 '1)
+  (bpl @loop)
+  (bx lr))
+
+(defparameter *simple-bit-boole-functions* ())
+
+(setq *simple-bit-boole-functions*
+      (vector
+       #'%boole-clr
+       #'%boole-set
+       #'%boole-1
+       #'%boole-2
+       #'%boole-c1
+       #'%boole-c2
+       #'%boole-and
+       #'%boole-ior
+       #'%boole-xor
+       #'%boole-eqv
+       #'%boole-nand
+       #'%boole-nor
+       #'%boole-andc1
+       #'%boole-andc2
+       #'%boole-orc1
+       #'%boole-orc2))
+
+(defun %simple-bit-boole (op b1 b2 result)
+  (funcall (svref *simple-bit-boole-functions* op)
+           (ash (the fixnum (+ (length result) 31)) -5)
+           b1
+           b2
+           result))
+
+
+(defarmlapfunction %aref2 ((array arg_x) (i arg_y) (j arg_z))
+  (check-nargs 3)
+  (ba .SParef2))
+
+(defarmlapfunction %aref3 ((array 0) (i arg_x) (j arg_y) (k arg_z))
+  (check-nargs 4)
+  (vpop1 temp0)
+  (ba .SParef3))
+
+
+(defarmlapfunction %aset2 ((array 0) (i arg_x) (j arg_y) (newval arg_z))
+  (check-nargs 4)
+  (vpop1 temp0)
+  (ba .SPaset2))
+
+(defarmlapfunction %aset3 ((array #.target::node-size) (i 0) (j arg_x) (k arg_y)  (newval arg_z))
+  (check-nargs 5)
+  (vpop1 temp0)
+  (vpop1 temp1)
+  (ba .SPaset3))
+  
+
Index: /branches/arm/level-0/ARM/arm-hash.lisp
===================================================================
--- /branches/arm/level-0/ARM/arm-hash.lisp	(revision 13756)
+++ /branches/arm/level-0/ARM/arm-hash.lisp	(revision 13756)
@@ -0,0 +1,117 @@
+;;; -*- 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
+
+;;; level-0;ARM;arm-hash.lisp
+
+
+(in-package "CCL")
+
+(eval-when (:compile-toplevel :execute)
+  (require "HASHENV" "ccl:xdump;hashenv"))
+
+
+
+
+;;; This should stay in LAP so that it's fast
+;;; Equivalent to cl:mod when both args are positive fixnums
+(defarmlapfunction fast-mod ((number arg_y) (divisor arg_z))
+  (build-lisp-frame imm0)
+  (mov imm0 (:lsr number (:$ arm::fixnumshift)))
+  (mov imm1 (:lsr divisor (:$ arm::fixnumshift)))
+  (bl .SPudiv32)
+  (box-fixnum arg_z imm1)
+  (return-lisp-frame imm0))
+
+
+(defarmlapfunction fast-mod-3 ((number arg_x) (divisor arg_y) (recip arg_z))
+  (mov imm0 (:lsr number (:$ arm::fixnumshift)))
+  (smull imm1 imm2 imm0 recip)
+  (smull imm2 imm0 imm1 divisor)
+  (sub number number imm0)
+  (sub number number divisor)
+  (mov imm0 (:asr number (:$ (1- arm::nbits-in-word))))
+  (and divisor divisor imm0)
+  (add arg_z number divisor)
+  (bx lr))
+
+(defarmlapfunction %dfloat-hash ((key arg_z))
+  (ldr imm0 (:@ key (:$ arm::double-float.value)))
+  (ldr imm1 (:@ key (:$ arm::double-float.val-low)))
+  (add imm0 imm0 imm1)
+  (box-fixnum arg_z imm0)
+  (bx lr))
+
+
+
+(defarmlapfunction %sfloat-hash ((key arg_z))
+  (ldr imm0 (:@ key (:$ arm::single-float.value)))
+  (box-fixnum arg_z imm0)
+  (bx lr))
+
+
+
+(defarmlapfunction %macptr-hash ((key arg_z))
+  (ldr imm0 (:@ key (:$ arm::macptr.address)))
+  (add imm0 imm0 (:lsr imm0 (:$ 24)))
+  (bic arg_z imm0 (:$ arm::fixnummask))
+  (bx lr))
+
+(defarmlapfunction %bignum-hash ((key arg_z))
+  (let ((header imm1)
+        (offset imm2)
+        (ndigits temp1)
+        (immhash imm0))
+    (mov immhash (:$ 0))
+    (mov offset (:$ arm::misc-data-offset))
+    (getvheader header key)
+    (header-length ndigits header)
+    (let ((next header))
+      @loop
+      (subs ndigits ndigits '1)
+      (ldr next (:@ key offset))
+      (add offset offset (:$ 4))
+      (add immhash next (:ror immhash (:$ 19)))
+      (bne @loop))
+    (bic arg_z immhash (:$ arm::fixnummask))
+    (bx lr)))
+
+
+
+
+(defarmlapfunction %get-fwdnum ()
+  (ref-global arg_z arm::fwdnum)
+  (bx lr))
+
+
+(defarmlapfunction %get-gc-count ()
+  (ref-global arg_z arm::gc-count)
+  (bx lr))
+
+
+;;; Setting a key in a hash-table vector needs to 
+;;; ensure that the vector header gets memoized as well
+(defarmlapfunction %set-hash-table-vector-key ((vector arg_x) (index arg_y) (value arg_z))
+  (ba .SPset-hash-key))
+
+(defarmlapfunction %set-hash-table-vector-key-conditional ((offset 0) (vector arg_x) (old arg_y) (new arg_z))
+  (ba .SPset-hash-key-conditional))
+
+;;; Strip the tag bits to turn x into a fixnum
+(defarmlapfunction strip-tag-to-fixnum ((x arg_z))
+  (bic arg_z x (:$ arm::fixnummask))
+  (bx lr))
+
+;;; end of arm-hash.lisp
Index: /branches/arm/level-0/ARM/arm-pred.lisp
===================================================================
--- /branches/arm/level-0/ARM/arm-pred.lisp	(revision 13756)
+++ /branches/arm/level-0/ARM/arm-pred.lisp	(revision 13756)
@@ -0,0 +1,182 @@
+;;;-*- 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-LAPMACROS"))
+
+(defarmlapfunction eql ((x arg_y) (y arg_z))
+  "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
+  (check-nargs 2)
+  @tail
+  (cmp x y)
+  (extract-lisptag imm0 x)
+  (extract-lisptag imm1 y)
+  (beq @win)
+  (cmp imm0 (:$ arm::tag-misc))
+  (cmpeq imm1 (:$ arm::tag-misc))
+  (bne @lose)
+  ;; Objects are both of tag-misc.  Headers must match exactly;
+  ;; dispatch on subtag.
+  (getvheader imm1 y)
+  (extract-lowbyte imm2 imm1)
+  (getvheader imm0 x)
+  (cmp imm2 (:$ arm::subtag-macptr))
+  (beq @macptr)
+  (cmp imm0 imm1)
+  (bne @lose)
+  (cmp imm2 (:$ arm::max-numeric-subtag))
+  (bgt @lose)
+  (cmp imm2 (:$ arm::subtag-ratio))
+  (cmpne imm2 (:$ arm::subtag-complex))
+  (beq @node)
+  (cmp imm2 (:$ arm::subtag-bignum))
+  (beq @bignum)
+  (cmp imm2 (:$ arm::subtag-double-float))
+  (bne @one-unboxed-word)
+  ;; This is the double-float case.
+  (ldr imm0 (:@ x (:$ arm::double-float.value)))
+  (ldr imm1 (:@ y (:$ arm::double-float.value)))
+  (cmp imm0 imm1)
+  (ldreq imm0 (:@ x (:$ arm::double-float.val-low)))
+  (ldreq imm1 (:@ y (:$ arm::double-float.val-low)))
+  (cmpeq imm0 imm1)
+  (mov arg_z 'nil)
+  (addeq arg_z arg_z (:$ arm::t-offset))
+  (bx lr)
+  @win
+  (mov arg_z 'nil)
+  (add arg_z arg_z ($ arm::t-offset))
+  (bx lr)
+  @macptr
+  (extract-lowbyte imm0 imm0)
+  (cmp imm2 imm0)
+  (bne @lose)
+  @one-unboxed-word
+  (ldr imm0 (:@ x (:$ arm::misc-data-offset)))
+  (ldr imm1 (:@ y (:$ arm::misc-data-offset)))
+  (cmp imm0 imm1)
+  (beq  @win)
+  @lose
+  (mov arg_z 'nil)
+  (bx lr)
+  @bignum
+  ;; Way back when, we got x's header into imm0.  We know that y's
+  ;; header is identical.  Use the element-count from imm0 to control
+  ;; the loop.  There's no such thing as a 0-element bignum, so the
+  ;; loop must always execute at least once.
+  (header-length temp0 imm0)
+  (mov imm2 (:$ arm::misc-data-offset))
+  @bignum-next
+  (ldr imm0 (:@ x imm2))
+  (ldr imm1 (:@ y imm2))
+  (cmp imm0 imm1)
+  (add imm2 imm2 (:$ arm::node-size))
+  (bne @lose)
+  (subs temp0 temp0 '1)
+  (bne @bignum-next)
+  (mov arg_z 'nil)
+  (add arg_z arg_z (:$ arm::t-offset))
+  (bx lr)
+  @node
+  ;; Have either a ratio or a complex.  In either case, corresponding
+  ;; elements of both objects must be EQL.  Recurse on the first
+  ;; elements.  If true, tail-call on the second, else fail.
+  (vpush1 x)
+  (vpush1 y)
+  (build-lisp-frame imm0)
+  (ldr x (:@ x (:$ arm::misc-data-offset)))
+  (ldr y (:@ y (:$ arm::misc-data-offset)))
+  (bl @tail)
+  (cmp arg_z 'nil)
+  (restore-lisp-frame imm0)
+  (vpop1 y)
+  (vpop1 x)
+  (beq @lose)
+  (ldr x (:@ x (:$ (+ 4 arm::misc-data-offset))))
+  (ldr y (:@ y (:$ (+ 4 arm::misc-data-offset))))
+  (b @tail))
+
+
+  
+
+(defarmlapfunction equal ((x arg_y) (y arg_z))
+  "Return T if X and Y are EQL or if they are structured components
+  whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
+  are the same length and have identical components. Other arrays must be
+  EQ to be EQUAL.  Pathnames are EQUAL if their components are."
+  (check-nargs 2)
+  @top
+  (cmp x y)
+  (extract-fulltag imm0 x)
+  (extract-fulltag imm1 y)
+  (beq @win)
+  (cmp imm0 imm1)
+  (bne @lose)
+  (cmp imm0 (:$ arm::fulltag-cons))
+  (beq @cons)
+  (cmp imm0 (:$ arm::fulltag-misc))
+  (beq @misc)
+  @lose
+  (mov arg_z 'nil)
+  (bx lr)
+  @win
+  (mov arg_z 'nil)
+  (add arg_z arg_z (:$ arm::t-offset))
+  (bx lr)
+  @cons
+  (%car temp0 x)
+  (%car temp1 y)
+  (cmp temp0 temp1)
+  (bne @recurse)
+  (%cdr x x)
+  (%cdr y y)
+  (b @top)
+  @recurse
+  (vpush1 x)
+  (vpush1 y)
+  (build-lisp-frame imm0)
+  (mov x temp0)
+  (mov y temp1)
+  (bl @top)
+  (cmp arg_z 'nul)  
+  (mov nfn fn)
+  (restore-lisp-frame imm0)           ; gets old fn to fn  
+  (vpop1 y)
+  (vpop1 x)
+  (beq  @lose)
+  (%cdr x x)
+  (%cdr y y)
+  (b @top)
+  @misc
+  (extract-subtag imm0 x)
+  (extract-subtag imm1 y)
+  (cmp imm0 (:$ arm::subtag-vectorH))
+  (cmpne imm1 (:$ arm::subtag-vectorH))
+  (beq @hairy)
+  (cmp imm0 (:$ arm::subtag-macptr))
+  (bgt @same)
+  (ldr fname (:@ nfn 'eql))
+  (ldr nfn (:@ fname (:$ arm::symbol.vcell)))
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
+  @same
+  (cmp imm1 imm0)
+  (bne @lose)
+  @hairy
+  (ldr fname (:@ nfn 'hairy-equal))
+  (ldr nfn (:@ fname (:$ arm::symbol.vcell)))
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))