Index: /branches/arm/compiler/ARM/arm-asm.lisp
===================================================================
--- /branches/arm/compiler/ARM/arm-asm.lisp	(revision 13750)
+++ /branches/arm/compiler/ARM/arm-asm.lisp	(revision 13751)
@@ -277,5 +277,5 @@
      ())
    (define-arm-instruction ands (:rd :rn :shifter)
-     #x00100000
+     #x01000000
      ((#x03000000 . #x0ff00000)
       (#x01000000 . #x0ff00010)
@@ -511,33 +511,33 @@
    (define-arm-instruction stm (:rnw :reglist)
      #x08800000
-     #x0ff00000
+     #x0fd00000
      ())
    (define-arm-instruction stmia (:rnw :reglist)
      #x08800000
-     #x0ff00000
+     #x0fd00000
      ())
    (define-arm-instruction stmea (:rnw :reglist)
      #x08800000
-     #x0ff00000
+     #x0fd00000
      ())
    (define-arm-instruction ldmia (:rnw :reglist)
      #x08900000
-     #x0ff00000
+     #x0fd00000
      ())
    (define-arm-instruction ldm (:rnw :reglist)
      #x08900000
-     #x0ff00000
+     #x0fd00000
      ())
    (define-arm-instruction ldmfd (:rnw :reglist)
      #x08900000
-     #x0ff00000
+     #x0fd00000
      ())
    (define-arm-instruction stmdb (:rnw :reglist)
      #x09000000
-     #x0ff00000
+     #x0fd00000
      ())
    (define-arm-instruction stmfb (:rnw :reglist)
      #x09000000
-     #x0ff00000
+     #x0fd00000
      ())
    (define-arm-instruction stmfd (:rnw :reglist)
@@ -547,18 +547,18 @@
    (define-arm-instruction ldmdb (:rnw :reglist)
      #x09100000
-     #x0ff00000
+     #x0fd00000
      ())
    (define-arm-instruction ldmea (:rnw :reglist)
      #x09100000
-     #x0ff00000
+     #x0fd00000
      ())
 
    (define-arm-instruction b (:b)
      #x0a000000
-     #x0e000000
+     #x0f000000
      ())
    (define-arm-instruction bl (:b)
      #x0b000000
-     #x0e000000
+     #x0f000000
      ())
    (define-arm-instruction bx (:rm)
@@ -916,8 +916,9 @@
   (ecase mode            
     ((:@ :+@ :+@! :@!)
-     ;; Preindexed, no writeback unless :+@! , add register operands.
+     ;; Preindexed, no writeback unless :[+]@! , add register operands.
      (unless constant-index
        (setq opcode (logior opcode (ash 1 23))))
-     (when (eq mode :+@!)
+     (when (or (eq mode :+@!)
+               (eq mode :@!))
        (setq opcode (logior opcode (ash 1 21))))
      (setq opcode (logior opcode (ash 1 24))))
@@ -1038,5 +1039,6 @@
 
 (defun parse-subprim-operand (form instruction) 
-  (let* ((address (arm-subprimitive-address form)))
+  (let* ((address (or (arm-subprimitive-address form)
+                      (when (arm-subprimitive-name form) form))))
     (unless address
       (error "Unknown ARM subprimitive : ~s" form))
@@ -1245,4 +1247,13 @@
 
 (defun arm-finalize (primary constant-pool)
+  (do-lap-labels (lab)
+    (loop
+      (when (dolist (ref (lap-label-refs lab) t)
+              (when (eq lab (lap-instruction-succ (car ref)))
+                (ccl::remove-dll-node (car ref))
+                (setf (lap-label-refs lab)
+                      (delete ref (lap-label-refs lab)))
+                (return)))
+        (return))))
   (dolist (lab *called-subprim-jmp-labels*)
     (unless (lap-label-emitted-p lab)
@@ -1363,6 +1374,5 @@
     :label
     :subprim
-    :application
-    :local-label
+    :data-label
     :dd
     :dm
@@ -1404,5 +1414,5 @@
   (let* ((p (position form vinsn-params)))
     (cond (p
-           (add-avi-operand avi encoded-type p)
+           (add-avi-operand avi encoded-type (list p))
            nil)
           (t           
@@ -1412,5 +1422,5 @@
   (let* ((p (position form vinsn-params)))
     (cond (p
-           (add-avi-operand avi encoded-type p)
+           (add-avi-operand avi encoded-type (list p))
            nil)
           (t           
@@ -1420,5 +1430,5 @@
   (let* ((p (position form vinsn-params)))
     (cond (p
-           (add-avi-operand avi encoded-type p)
+           (add-avi-operand avi encoded-type (list p))
            nil)
           (t
@@ -1445,8 +1455,9 @@
   (let* ((p (position form vinsn-params)))
     (cond (p
-           (add-avi-operand avi encoded-type p)
+           (add-avi-operand avi encoded-type (list p))
            nil)
-          ((typep form 'keyword)
-           (add-avi-operand avi encoded-type form)
+          ((and (typep form 'keyword)
+                (eql encoded-type (encode-vinsn-field-type :mem12-offset)))
+           (add-avi-operand avi (encode-vinsn-field-type :data-label) form)
            nil)
           ((and (consp form) (eq (car form) :apply))
@@ -1477,5 +1488,7 @@
              (let* ((constant (encode-arm-immediate val)))
                (if constant
-                 (set-avi-opcode-field avi (byte 1 25) 1)
+                 (progn
+                   (set-avi-opcode-field avi (byte 1 25) 1)
+                   (set-avi-opcode-field avi (byte 12 0) constant))
                  (let* ((op (ldb (byte 4 21) (avi-opcode avi)))
                         (newop nil))
@@ -1504,9 +1517,10 @@
            (t
             (unless (eq (car count) :$)
-              (error "Invalid shift count: ~s" count)
-              (destructuring-bind (countval) (cdr count)
-                (vinsn-arg-or-constant avi countval vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7)))))))))))
+              (error "Invalid shift count: ~s" count))
+            (destructuring-bind (countval) (cdr count)
+              (vinsn-arg-or-constant avi countval vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7))))))))))
 
 (defun vinsn-parse-m12-operand (avi value vinsn-params)
+
   (when (typep value 'keyword)
     (setq value `(:@ arm::pc (:$ ,value))))
@@ -1551,5 +1565,5 @@
     (let* ((p (position r vinsn-params)))
       (if p
-        (add-avi-operand avi (encode-vinsn-field-type :reglist-bit) p)
+        (add-avi-operand avi (encode-vinsn-field-type :reglist-bit) (list p))
         (let* ((bit (need-arm-gpr r)))
           (setf (avi-opcode avi)
@@ -1584,11 +1598,14 @@
 (defun vinsn-parse-b-operand (avi value vinsn-params)
   ;; Pretty much has to be a param or a local label what else would we b to ?
-  (let* ((p (position value vinsn-params)))
+  (let* ((p (position value vinsn-params))
+         (addr nil))
     (cond (p
-           (add-avi-operand avi (encode-vinsn-field-type :label) p))
+           (add-avi-operand avi (encode-vinsn-field-type :label) (list p)))
           ((typep value 'keyword)
-           (add-avi-operand avi (encode-vinsn-field-type :local-label) value))
-          ((arm-subprimitive-address value)
-           (add-avi-operand avi (encode-vinsn-field-type :subprim) value))
+           (add-avi-operand avi (encode-vinsn-field-type :label) value))
+          ((setq addr (arm-subprimitive-address value))
+           (add-avi-operand avi (encode-vinsn-field-type :label) addr))
+          ((arm-subprimitive-name value)
+           (add-avi-operand avi (encode-vinsn-field-type :label) addr))
           (t
            (error "Unknown branch target: ~s." value)))))
@@ -1599,5 +1616,5 @@
   (let* ((p (position value vinsn-params)))
     (if p
-      (add-avi-operand avi (encode-vinsn-field-type :subprim) p)
+      (add-avi-operand avi (encode-vinsn-field-type :subprim) (list p))
       (let* ((addr (or (arm-subprimitive-address value)
                    (and (typep value 'integer)
@@ -1606,5 +1623,5 @@
                         (not (logtest #x7f value))))))
         (unless addr
-          (error "Unknown ARM subprimitive address: ~s." addr))
+          (error "Unknown ARM subprimitive address: ~s." value))
         (set-avi-opcode-field avi (byte 12 0) (encode-arm-immediate addr))))))
 
@@ -1700,5 +1717,5 @@
                                                 (encode-vinsn-field-type :cond)
                                                 (encode-vinsn-field-type :negated-cond))
-                                          p)
+                                          (list p))
                          (setq cond nil)))
                      (let* ((c (need-arm-condition-name cond-name)))
@@ -1725,26 +1742,119 @@
 
 (defparameter *arm-vinsn-insert-functions*
-    #(vinsn-insert-rd-operand
-      vinsn-insert-rn-operand
-      vinsn-insert-shifter-operand
-      vinsn-insert-m12-operand
-      vinsn-insert-reglist-operand
-      vinsn-insert-rnw-operand
-      vinsn-insert-uuoa-operand
-      vinsn-insert-uuo-unary-operand
-      vinsn-insert-uuob-operand
-      vinsn-insert-rm-operand
-      vinsn-insert-b-operand
-      vinsn-insert-subprim-operand
-      vinsn-insert-m8-operand
-      vinsn-insert-dd-operand
-      vinsn-insert-dm-operand
-      vinsn-insert-sd-operand
-      vinsn-insert-sm-operand
-      vinsn-insert-dn-operand
-      vinsn-insert-sn-operand
-      vinsn-insert-rde-operand
-      vinsn-insert-rs-operand
-      ))
+  #(vinsn-insert-cond-operand
+    vinsn-insert-negated-cond-operand
+    vinsn-insert-rn-operand
+    vinsn-insert-rd-operand
+    vinsn-insert-rm-operand
+    vinsn-insert-rs-operand
+    vinsn-insert-alu-constant-operand
+    vinsn-insert-shift-count-operand                        ;shift type is always explicit
+    vinsn-insert-mem12-offset-operand
+    vinsn-insert-mem8-offset-operand
+    vinsn-insert-reglist-bit-operand
+    vinsn-insert-uuoA-operand
+    vinsn-insert-uuo-unary-operand
+    vinsn-insert-uuoB-operand
+    vinsn-insert-label-operand
+    vinsn-insert-subprim-operand
+    vinsn-insert-data-label-operand
+    vinsn-insert-dd-operand
+    vinsn-insert-dm-operand
+    vinsn-insert-sd-operand
+    vinsn-insert-sm-operand
+    vinsn-insert-dn-operand
+    vinsn-insert-sn-operand
+    ))
+
+(defun vinsn-insert-cond-operand (instruction value)
+  (set-field-value instruction (byte 4 28) value))
+
+(defun vinsn-insert-negated-cond-operand (instruction value)
+  (set-field-value instruction (byte 4 28) (logxor value 1)))
+
+(defun vinsn-insert-rn-operand (instruction value)
+  (set-field-value instruction (byte 4 16) value))
+
+(defun vinsn-insert-rd-operand (instruction value)
+  (set-field-value instruction (byte 4 12) value))
+
+(defun vinsn-insert-rm-operand (instruction value)
+  (set-field-value instruction (byte 4 0) value))
+
+(defun vinsn-insert-rs-operand (instruction value)
+  (set-field-value instruction (byte 4 8) value))
+
+(defun vinsn-insert-alu-constant-operand (instruction value)
+  (insert-shifter-constant value instruction))
+
+(defun vinsn-insert-shift-count-operand (instruction value)
+  (set-field-value instruction (byte 5 7) value))
+
+(defun vinsn-insert-mem12-offset-operand (instruction value)
+  (if (typep value 'lap-label)
+    (lap-note-label-reference value instruction :mem12)
+    (progn
+      (if (< value 0)
+        (setq value (- value))
+        (set-field-value instruction (byte 1 23) 1))
+      (set-field-value instruction (byte 12 0) value))))
+
+(defun vinsn-insert-mem8-offset-operand (instruction value) 
+  (if (< value 0)
+    (setq value (- value))
+    (set-field-value instruction (byte 1 23) 1))
+  (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value))
+  (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value)))
+
+(defun vinsn-insert-reglist-bit-operand (instruction value)
+  (set-field-value instruction (byte 1 value) 1))
+
+(defun vinsn-insert-uuoA-operand (instruction value)
+  (set-field-value instruction (byte 4 8) value))
+
+(defun vinsn-insert-uuo-unary-operand (instruction value)
+  (set-field-value instruction (byte 8 12) value))
+
+(defun vinsn-insert-uuoB-operand (instruction value)
+  (set-field-value instruction (byte 4 12) value))
+
+(defun vinsn-insert-label-operand (instruction value)
+  (let* ((label (etypecase value
+                  (lap-label value)
+                  (ccl::vinsn-label
+                   (or (find-lap-label value)
+                       (make-lap-label value)))
+                  (fixnum (let* ((lab (or (find-lap-label value)
+                                          (make-lap-label value))))
+                            (pushnew lab *called-subprim-jmp-labels*)
+                            lab)))))
+    (push (cons instruction :b) (lap-label-refs label))))
+
+(defun vinsn-insert-subprim-operand (instruction value)
+  )
+
+(defun vinsn-insert-data-label-operand (instruction value)
+  )
+
+(defun vinsn-insert-dd-operand (instruction value)
+  (set-field-value instruction (byte 4 12) value) )
+
+(defun vinsn-insert-dm-operand (instruction value)
+  (set-field-value instruction (byte 4 0) value))
+
+(defun vinsn-insert-sd-operand (instruction value)
+  )
+
+(defun vinsn-insert-sm-operand (instruction value)
+  )
+
+(defun vinsn-insert-dn-operand (instruction value)
+  (set-field-value instruction (byte 4 16) value))
+
+(defun vinsn-insert-sn-operand (instruction value)
+  )
+    
+
+
 
 (provide "ARM-ASM")
Index: /branches/arm/compiler/ARM/arm-disassemble.lisp
===================================================================
--- /branches/arm/compiler/ARM/arm-disassemble.lisp	(revision 13750)
+++ /branches/arm/compiler/ARM/arm-disassemble.lisp	(revision 13751)
@@ -264,4 +264,6 @@
     extract-arm-dn-operand
     extract-arm-sn-operand
+    extract-arm-rd-operand                  ;rde
+    extract-arm-rs-operand
     ))
 
Index: /branches/arm/compiler/ARM/arm-vinsns.lisp
===================================================================
--- /branches/arm/compiler/ARM/arm-vinsns.lisp	(revision 13750)
+++ /branches/arm/compiler/ARM/arm-vinsns.lisp	(revision 13751)
@@ -1212,5 +1212,5 @@
                                     ((object :lisp))
                                     ((tag :u8)))
-  (ands tag object (:$ arm::tagmask))
+  (and tag object (:$ arm::tagmask))
   (cmp tag (:$ arm::tag-list))
   (uuo-error-reg-not-lisptag (:? ne) object (:$ arm::tag-list)))
@@ -1328,208 +1328,10 @@
 
 
-;; Sometimes we try to extract a single bit from some source register
-;; into a destination bit (typically 31, sometimes fixnum bit 0 = 29).
-;; If we copy bit 0 (whoops, I mean "bit 31") to bit 4 (aka 27) in a
-;; given register, we get a value that's either 17 (the arithmetic difference
-;; between T and NIL) or 0.
-
-#+later
-(define-arm-vinsn lowbit->truth (((dest :lisp)
-                                  (bits :u32))
-                                 ((bits :u32))
-                                 ())
-  (rlwimi bits bits (- arm::least-significant-bit 27) 27 27) ; bits = 0000...X000X
-  (addi dest bits (:apply target-nil-value)))
-
-#+later
-(define-arm-vinsn invert-lowbit (((bits :u32))
-                                 ((bits :u32))
-                                 ())
-  (xori bits bits 1))
 
                            
 
-(define-arm-vinsn eq0->boolean (((dest t))
-                                ((src t)))
-  (cmp src (:$ 0))
-  (mov dest (:$ arm::nil-value))
-  (addeq dest dest (:$ arm::t-offset)))                
-
-
-(define-arm-vinsn ne0->boolean (((dest t))
-                                ((src t)))
-  (cmp src (:$ 0))
-  (mov dest (:$ arm::nil-value))
-  (addne dest dest (:$ arm::t-offset)))
-
-(define-arm-vinsn lt0->boolean (((dest t))
-                                ((src t)))
-  (cmp src (:$ 0))
-  (mov dest (:$ arm::nil-value))
-  (addmi dest dest (:$ arm::t-offset)))                
-
-
-#+later
-(define-arm-vinsn ge0->bit31 (((bits :u32))
-                              ((src (t (:ne bits)))))
-  (srwi bits src 31)       
-  (xori bits bits 1))                   ; bits = 0000...000X
-
-#+later
-(define-arm-vinsn le0->bit31 (((bits :u32))
-                              ((src (t (:ne bits)))))
-  (neg bits src)
-  (orc bits bits src)
-  (srwi bits bits 31))                  ; bits = 0000...000X
-
-#+later
-(define-arm-vinsn gt0->bit31 (((bits :u32))
-                              ((src (t (:ne bits)))))
-  (subi bits src 1)       
-  (nor bits bits src)
-  (srwi bits bits 31))                  ; bits = 0000...000X
-
-#+later
-(define-arm-vinsn ne->bit31 (((bits :u32))
-                             ((x t)
-                              (y t))
-                             ((temp :u32)))
-  (subf temp x y)
-  (cntlzw bits temp)
-  (slw bits temp bits)
-  (srwi bits bits 31))                  ; bits = 0000...000X
-
-#+later
-(define-arm-vinsn fulltag->bit31 (((bits :u32))
-                                  ((lispobj :lisp)
-                                   (tagval :u8const))
-                                  ())
-  (clrlwi bits lispobj (- arm::nbits-in-word arm::ntagbits))
-  (subi bits bits tagval)
-  (cntlzw bits bits)
-  (srwi bits bits 5))
-
-#+later
-(define-arm-vinsn eq->bit31 (((bits :u32))
-                             ((x t)
-                              (y t)))
-  (subf bits x y)
-  (cntlzw bits bits)
-  (srwi bits bits 5))                   ; bits = 0000...000X
-
-#+later
-(define-arm-vinsn eqnil->bit31 (((bits :u32))
-                                ((x t)))
-  (subi bits x (:apply target-nil-value))
-  (cntlzw bits bits)
-  (srwi bits bits 5))
-
-#+later
-(define-arm-vinsn ne->bit31 (((bits :u32))
-                             ((x t)
-                              (y t)))
-  (subf bits x y)
-  (cntlzw bits bits)
-  (srwi bits bits 5)
-  (xori bits bits 1))
-
-#+later
-(define-arm-vinsn nenil->bit31 (((bits :u32))
-                                ((x t)))
-  (subi bits x (:apply target-nil-value))
-  (cntlzw bits bits)
-  (srwi bits bits 5)
-  (xori bits bits 1))
-
-#+later
-(define-arm-vinsn lt->bit31 (((bits :u32))
-                             ((x (t (:ne bits)))
-                              (y (t (:ne bits)))))
-
-  (xor bits x y)
-  (srawi bits bits 31)
-  (or bits bits x)
-  (subf bits y bits)
-  (srwi bits bits 31))                  ; bits = 0000...000X
-
-#+later
-(define-arm-vinsn ltu->bit31 (((bits :u32))
-                              ((x :u32)
-                               (y :u32)))
-  (subfc bits y x)
-  (subfe bits bits bits)
-  (neg bits bits))
-
-#+later
-(define-arm-vinsn le->bit31 (((bits :u32))
-                             ((x (t (:ne bits)))
-                              (y (t (:ne bits)))))
-
-  (xor bits x y)
-  (srawi bits bits 31)
-  (nor bits bits y)
-  (add bits bits x)
-  (srwi bits bits 31))                  ; bits = 0000...000X
-
-#+later
-(define-arm-vinsn leu->bit31  (((bits :u32))
-                               ((x :u32)
-                                (y :u32)))
-  (subfc bits x y)
-  (addze bits arm::rzero))
-
-#+later
-(define-arm-vinsn gt->bit31 (((bits :u32))
-                             ((x (t (:ne bits)))
-                              (y (t (:ne bits)))))
-
-  (eqv bits x y)
-  (srawi bits bits 31)
-  (and bits bits x)
-  (subf bits bits y)
-  (srwi bits bits 31))                  ; bits = 0000...000X
-
-#+later
-(define-arm-vinsn gtu->bit31 (((bits :u32))
-                              ((x :u32)
-                               (y :u32)))
-  (subfc bits x y)
-  (subfe bits bits bits)
-  (neg bits bits))
-
-#+later
-(define-arm-vinsn ge->bit31 (((bits :u32))
-                             ((x (t (:ne bits)))
-                              (y (t (:ne bits)))))
-  (eqv bits x y)
-  (srawi bits bits 31)
-  (andc bits bits x)
-  (add bits bits y)
-  (srwi bits bits 31))                  ; bits = 0000...000X
-
-#+later
-(define-arm-vinsn geu->bit31 (((bits :u32))
-                              ((x :u32)
-                               (y :u32)))
-  (subfc bits y x)
-  (addze bits arm::rzero))
-
-
-;;; there are big-time latencies associated with MFCR on more heavily
-;;; pipelined processors; that implies that we should avoid this like
-;;; the plague.
-;;; GSO can't find anything much quicker for LT or GT, even though
-;;; MFCR takes three cycles and waits for previous instructions to complete.
-;;; Of course, using a CR field costs us something as well.
-#+later
-(define-arm-vinsn crbit->bit31 (((bits :u32))
-                                ((crf :crf)
-                                 (bitnum :crbit))
-                                ())
-  (mfcr bits)                           ; Suffer.
-  (rlwinm bits bits (:apply + 1  bitnum (:apply ash crf 2)) 31 31)) ; bits = 0000...000X
-
-
-(define-arm-vinsn compare (()
+
+
+(define-arm-vinsn compare (((crf :crf))
                            ((arg0 t)
                             (arg1 t))
@@ -1537,5 +1339,5 @@
   (cmp arg0 arg1))
 
-(define-arm-vinsn compare-to-nil (()
+(define-arm-vinsn compare-to-nil (((crf :crf))
                                   ((arg0 t)))
   (cmp arg0 (:$ arm::nil-value)))
@@ -1722,8 +1524,27 @@
   (str reg (:@! vsp (:$ (- arm::node-size)))))
 
+(define-arm-vinsn (vpush-xyz :push :node :vsp) (() ())
+  (stmdb (:! vsp) (arg_z arg_y arg_x)))
+
+(define-arm-vinsn (vpush-yz :push :node :vsp) (() ())
+  (stmdb (:! vsp) (arg_z arg_y)))
+
+    
+
 (define-arm-vinsn (vpop-register :pop :node :vsp)
     (((dest :lisp))
      ())
   (ldr dest (:@+ vsp (:$ arm::node-size))))
+
+(define-arm-vinsn (pop-argument-registers :pop :node :vsp) (()
+                                                            ())
+  (cmp nargs (:$ 0))
+  (beq :done)
+  (cmp nargs (:$ (* 2 arm::fixnumshift)))
+  (ldrlt arg_z (:@+ vsp (:$ arm::node-size)))
+  (ldmiaeq (:! vsp) (arg_z arg_y))
+  (ldmiagt (:! vsp) (arg_z arg_y arg_x))
+  :done)
+
 
 
@@ -1865,4 +1686,5 @@
 (define-arm-vinsn (cbranch-true :branch) (()
                                           ((label :label)
+                                           (crf :crf)
                                            (crbit :u8const)))
   (b (:? crbit) label))
@@ -1870,7 +1692,12 @@
 (define-arm-vinsn (cbranch-false :branch) (()
                                            ((label :label)
+                                            (crf :crf)
                                             (crbit :u8const)))
   (b (:~ crbit) label))
 
+(define-arm-vinsn cond->boolean (((dest :imm))
+                                 ((cond :u8const)))
+  (mov dest (:$ arm::nil-value))
+  (add (:? cond) dest dest (:$ arm::t-offset)))
 
 
@@ -2734,5 +2561,5 @@
   (subs dest x y)
   (bvc target)
-  (mov unboxed (:asr dest (:$ arm::fixnumshift0)))
+  (mov unboxed (:asr dest (:$ arm::fixnumshift)))
   (mov header (:$ arm::subtag-bignum))
   (orr header header (:$ (ash 1 arm::num-subtag-bits)))
@@ -2963,9 +2790,19 @@
 (define-arm-vinsn save-lisp-context-offset (()
                                             ((nbytes-vpushed :u16const))
-                                            ((imm :imm)))
+                                            ((imm (:u32 #.arm::imm1))))
   (add imm vsp (:$ nbytes-vpushed))
   (mov imm0 (:$ arm::lisp-frame-marker))
   (stmdb (:! sp) (imm0 imm fn lr))
   (mov fn nfn))
+
+(define-arm-vinsn save-lisp-context-variable (()
+                                              ()
+                                              ((imm (:u32 #.arm::imm1))))
+  (subs imm nargs (:$ (ash $numarmargregs arm::word-shift)))
+  (movmi imm (:$ 0))
+  (add imm imm vsp)
+  (mov imm0 (:$ arm::lisp-frame-marker))
+  (stmdb (:! sp) (imm0 imm fn lr))
+  (mov fn nfn))  
 
 
@@ -3364,5 +3201,4 @@
     (ba ,spno)))
 
-(define-arm-subprim-jump-vinsn (restore-interrupt-level) .SPrestoreintlevel)
 
 (define-arm-subprim-call-vinsn (save-values) .SPsave-values)
@@ -3372,7 +3208,4 @@
 (define-arm-subprim-call-vinsn (add-values) .SPadd-values)
 
-(define-arm-subprim-jump-vinsn (jump-known-symbol-ool) .SPjmpsym)
-
-(define-arm-subprim-call-vinsn (call-known-symbol-ool)  .SPjmpsym)
 
 (define-arm-subprim-call-vinsn (pass-multiple-values)  .SPmvpass)
@@ -3388,7 +3221,4 @@
 (define-arm-subprim-jump-vinsn (tail-call-fn-slide) .SPtcallnfnslide)
 
-(define-arm-subprim-jump-vinsn (tail-call-sym-vsp) .SPtcallsymvsp)
-
-(define-arm-subprim-jump-vinsn (tail-call-fn-vsp) .SPtcallnfnvsp)
 
 (define-arm-subprim-call-vinsn (funcall)  .SPfuncall)
@@ -3400,9 +3230,8 @@
 (define-arm-subprim-jump-vinsn (tail-funcall-vsp) .SPtfuncallvsp)
 
-(define-arm-subprim-call-vinsn (spread-lexpr)  .SPspread-lexpr-z)
+(define-arm-subprim-call-vinsn (spread-lexpr)  .SPspread-lexprz)
 
 (define-arm-subprim-call-vinsn (spread-list)  .SPspreadargz)
 
-(define-arm-subprim-call-vinsn (pop-argument-registers)  .SPvpopargregs)
 
 (define-arm-subprim-call-vinsn (getu32) .SPgetu32)
@@ -3410,5 +3239,4 @@
 (define-arm-subprim-call-vinsn (gets32) .SPgets32)
 
-(define-arm-subprim-call-vinsn (getxlong)  .SPgetXlong)
 
 (define-arm-subprim-call-vinsn (stack-cons-list)  .SPstkconslist)
@@ -3511,5 +3339,5 @@
 
 (define-arm-subprim-call-vinsn (mkunwind) .SPmkunwind)
-(define-arm-subprim-call-vinsn (nmkunwind) .SPnmkunwind)
+(define-arm-subprim-call-vinsn (nmkunwind) .SPmkunwind)
 
 
@@ -3518,5 +3346,4 @@
 (define-arm-subprim-jump-vinsn (progvrestore) .SPprogvrestore)
 
-(define-arm-subprim-call-vinsn (eabi-syscall) .SPeabi-syscall)
 
 (define-arm-subprim-call-vinsn (misc-ref) .SPmisc-ref)
@@ -3536,9 +3363,5 @@
 
 
-(define-arm-subprim-call-vinsn (eabi-ff-call) .SPeabi-ff-call)
-
-(define-arm-subprim-call-vinsn (poweropen-ff-call) .SPpoweropen-ffcall)
-
-(define-arm-subprim-call-vinsn (poweropen-ff-callX) .SPpoweropen-ffcallX)
+
 
 (define-arm-subprim-call-vinsn (bind-interrupt-level-0) .SPbind-interrupt-level-0)
Index: /branches/arm/compiler/ARM/arm2.lisp
===================================================================
--- /branches/arm/compiler/ARM/arm2.lisp	(revision 13750)
+++ /branches/arm/compiler/ARM/arm2.lisp	(revision 13751)
@@ -1,6 +1,5 @@
-;;;-*-Mode: LISP; Package: CCL -*-
+;;-*-Mode: LISP; Package: CCL -*-
 ;;;
-;;;   Copyright (C) 2009 Clozure Associates
-;;;   Copyright (C) 1994-2001 Digitool, Inc
+;;;   Copyright (C) 2010 Clozure Associates
 ;;;   This file is part of Clozure CL.  
 ;;;
@@ -63,9 +62,11 @@
                     (unless ,template-temp
                       (warn "VINSN \"~A\" not defined" ,template-name-var))
-                    `(%emit-vinsn ,',segvar ',,template-name-var (backend-p2-vinsn-templates *target-backend*) ,@,args-var))))
+                    `(arm2-update-regmap (%emit-vinsn ,',segvar ',,template-name-var (backend-p2-vinsn-templates *target-backend*) ,@,args-var)))))
        (macrolet ((<- (,retvreg-var)
                     `(arm2-copy-register ,',segvar ,',vreg-var ,,retvreg-var))
                   (@  (,labelnum-var)
-                    `(backend-gen-label ,',segvar ,,labelnum-var))
+                    `(progn
+                      (arm2-invalidate-regmap)
+                      (backend-gen-label ,',segvar ,,labelnum-var)))
                   (-> (,label-var)
                     `(! jump (aref *backend-labels* ,,label-var)))
@@ -116,7 +117,4 @@
 (defvar *arm2-register-restore-ea* nil)
 (defvar *arm2-compiler-register-save-label* nil)
-(defvar *arm2-valid-register-annotations* 0)
-(defvar *arm2-register-annotation-types* nil)
-(defvar *arm2-register-ea-annotations* nil)
 
 (defparameter *arm2-tail-call-aliases*
@@ -163,4 +161,6 @@
 
 (defvar *arm2-result-reg* arm::arg_z)
+(defvar *arm2-gpr-locations* nil)
+(defvar *arm2-gpr-locations-valid-mask* 0)
 
 
@@ -374,6 +374,4 @@
            (*arm2-register-restore-count* nil)
            (*arm2-compiler-register-save-label* nil)
-           (*arm2-valid-register-annotations* 0)
-           (*arm2-register-ea-annotations* (arm2-make-stack 16))
            (*arm2-register-restore-ea* nil)
            (*arm2-vstack* 0)
@@ -397,4 +395,6 @@
            (*backend-fp-temps* arm-temp-fp-regs)
            (*available-backend-fp-temps* arm-temp-fp-regs)
+           (*backend-crf-temps* arm-cr-fields)
+           (*available-backend-crf-temps* arm-cr-fields)
            (bits 0)
            (*logical-register-counter* -1)
@@ -426,5 +426,8 @@
            (*arm2-fcells* (afunc-fcells afunc))
            *arm2-recorded-symbols*
-           (*arm2-emitted-source-notes* '()))
+           (*arm2-emitted-source-notes* '())
+           (*arm2-gpr-locations-valid-mask* 0)
+           (*arm2-gpr-locations* (make-array 16 :initial-element nil)))
+      (declare (dynamic-extent *arm2-gpr-locations*))
       (set-fill-pointer
        *backend-labels*
@@ -490,32 +493,14 @@
     afunc))
 
-(defun arm2-xmake-function (code data labels imms bits)
-  (let* ((arm::*lap-labels* labels)
-         (cross-compiling (target-arch-case
-                           (:arm (not (eq *host-backend* target-backend)))
-                           (t t)))
-         (numimms (length imms))
-         (function (%alloc-misc (+ numimms 3)
-                                (if cross-compiling
-                                  target::subtag-xfunction
-                                  target::subtag-function))))
-    (dotimes (i numimms)
-      (setf (uvref function (1+ 2)) (aref imms i)))
-    (setf (uvref function (+ numimms 1)) bits)
-    (let* ((code-vector-size (arm::arm-finalize code data))
-           (code-vector (%alloc-misc code-vector-size
-                                     (if cross-compiling
-                                       target::subtag-xcode-vector
-                                       target::subtag-code-vector)))
-           (j 0))
-      (dotimes (i prefix-size)
-        (setf (uvref code-vector i) (pop prefix)))
-      (arm-lap-resolve-labels)
-      (do-dll-nodes (insn *lap-instructions*)
-        (arm-lap-generate-instruction code-vector i insn)
-        (incf i))
-      (setf (uvref function 1) code-vector)
-      (%make-code-executable code-vector)
-      function)))
+(defun arm2-xmake-function (code data imms bits)
+  (collect ((lap-imms))
+    (dotimes (i (length imms))
+      (lap-imms (cons (aref imms i) i)))
+    (let* ((arm::*arm-constants* (lap-imms)))
+      (arm-lap-generate-code code
+                             (arm::arm-finalize code data)
+                             bits))))
+
+
       
     
@@ -538,4 +523,45 @@
               (if (eq (%svref v i) ref)
                 (setf (%svref v i) ref-fun)))))))))
+
+(eval-when (:compile-toplevel)
+  (declaim (inline arm2-invalidate-regmap)))
+
+(defun arm2-invalidate-regmap ()
+  (setq *arm2-gpr-locations-valid-mask* 0))
+
+(defun arm2-update-regmap (vinsn)
+  (if (vinsn-attribute-p vinsn :call :jump)
+    (arm2-invalidate-regmap)
+    (setq *arm2-gpr-locations-valid-mask* (logandc2 *arm2-gpr-locations-valid-mask* (vinsn-gprs-set vinsn))))
+  vinsn)
+
+(defun arm2-regmap-note-store (gpr loc)
+  (let* ((gpr (%hard-regspec-value gpr)))
+    ;; Any other GPRs that had contained loc no longer do so.
+    (dotimes (i 16)
+      (unless (eql i gpr)
+        (when (and (logbitp i *arm2-gpr-locations-valid-mask*)
+                   (eql loc (svref *arm2-gpr-locations* i)))
+          (setq *arm2-gpr-locations-valid-mask* (logandc2 *arm2-gpr-locations-valid-mask* (ash 1 i))))))
+    (setf (svref *arm2-gpr-locations* gpr) loc)
+    (setq *arm2-gpr-locations-valid-mask* (logior *arm2-gpr-locations-valid-mask* (ash 1 gpr)))))
+  
+;;; For vpush: nothing else should claim to contain loc.
+(defun arm2-regmap-note-reg-location (gpr loc)
+  (let* ((gpr (%hard-regspec-value gpr)))
+    (setf (svref *arm2-gpr-locations* gpr) loc)
+    (setq *arm2-gpr-locations-valid-mask* (logior *arm2-gpr-locations-valid-mask* (ash 1 gpr)))))  
+  
+(defun arm2-regmap-note-vstack-delta (new old)
+  (when (< new old)
+    (let* ((mask *arm2-gpr-locations-valid-mask*)
+           (info *arm2-gpr-locations*))
+    (unless (eql 0 mask)
+      (dotimes (i 16 (setq *arm2-gpr-locations-valid-mask* mask))
+        (when (logbitp i mask)
+          (let* ((loc (svref info i)))
+            (when (>= loc new)
+              (setq mask (logandc2 mask (ash 1 i)))))))))))
+
 
 (defun arm2-generate-pc-source-map (debug-info)
@@ -819,4 +845,5 @@
           (! save-lisp-context-offset offset)))
       (destructuring-bind (&optional zvar yvar xvar &rest stack-args) revargs
+        (declare (ignore xvar yvar))
         (let* ((nstackargs (length stack-args)))
           (arm2-set-vstack (* nstackargs *arm2-target-node-size*))
@@ -824,9 +851,22 @@
             (arm2-new-vstack-lcell :reserved *arm2-target-lcell-size* 0 nil))
           (if (>= nargs 3)
-            (push (arm2-vpush-arg-register seg ($ arm::arg_x) xvar) reg-vars))
-          (if (>= nargs 2)
-            (push (arm2-vpush-arg-register seg ($ arm::arg_y) yvar) reg-vars))
-          (if (>= nargs 1)
-            (push (arm2-vpush-arg-register seg ($ arm::arg_z) zvar) reg-vars))))
+            (progn
+              (! vpush-xyz)
+              (arm2-regmap-note-store arm::arg_x *arm2-vstack*)
+              (arm2-regmap-note-store arm::arg_y (+ *arm2-target-node-size* *arm2-vstack*))
+              (arm2-regmap-note-store arm::arg_z (+ (* 2 *arm2-target-node-size*) *arm2-vstack*))
+              (dotimes (i 3)
+                (arm2-new-vstack-lcell :reserved *arm2-target-lcell-size* 0 nil))
+              (arm2-adjust-vstack (* 3 *arm2-target-node-size*)))
+            (if (= nargs 2)
+              (progn
+                (! vpush-yz)
+                (arm2-regmap-note-store arm::arg_y *arm2-vstack*)
+                (arm2-regmap-note-store arm::arg_z (+ *arm2-target-node-size* *arm2-vstack*))
+                (dotimes (i 2)
+                  (arm2-new-vstack-lcell :reserved *arm2-target-lcell-size* 0 nil))
+                (arm2-adjust-vstack (* 2 *arm2-target-node-size*)))
+              (if (= nargs 1)
+                (push (arm2-vpush-arg-register seg ($ arm::arg_z) zvar) reg-vars))))))
       reg-vars)))
 
@@ -1067,4 +1107,5 @@
 
 (defun arm2-set-vstack (new)
+  (arm2-regmap-note-vstack-delta new *arm2-vstack*)
   (setq *arm2-vstack* new))
 
@@ -1096,5 +1137,27 @@
 (defun arm2-stack-to-register (seg memspec reg)
   (with-arm-local-vinsn-macros (seg)
-    (! vframe-load reg (memspec-frame-address-offset memspec) *arm2-vstack*)))
+    (let* ((offset (memspec-frame-address-offset memspec))
+           (mask *arm2-gpr-locations-valid-mask*)
+           (info *arm2-gpr-locations*)
+           (regno (%hard-regspec-value reg)))
+      (unless (and (logbitp regno mask)
+                   (eql offset (svref info regno)))
+        (let* ((other (dotimes (i 16)
+                        (when (and (logbitp i mask)
+                                   (eql offset (svref info i)))
+                          (return i)))))
+          (cond (other
+                 (let* ((vinsn (! copy-node-gpr reg other)))
+                   (setq *arm2-gpr-locations-valid-mask*
+                         (logior mask (ash 1 regno)))
+                   (setf (svref info regno)
+                         (svref info other))
+                   vinsn))
+                (t
+                 (let* ((vinsn (! vframe-load reg offset *arm2-vstack*)))
+                   (setq *arm2-gpr-locations-valid-mask*
+                         (logior mask (ash 1 regno)))
+                   (setf (svref info regno) offset)
+                   vinsn))))))))
 
 (defun arm2-lcell-to-register (seg lcell reg)
@@ -1108,5 +1171,8 @@
 (defun arm2-register-to-stack (seg reg memspec)
   (with-arm-local-vinsn-macros (seg)
-    (! vframe-store reg (memspec-frame-address-offset memspec) *arm2-vstack*)))
+    (let* ((offset (memspec-frame-address-offset memspec))
+           (vinsn (! vframe-store reg offset *arm2-vstack*)))
+      (arm2-regmap-note-store (%hard-regspec-value reg) offset)
+      vinsn)))
 
 
@@ -2227,7 +2293,5 @@
 (defun arm2-restore-full-lisp-context (seg)
   (with-arm-local-vinsn-macros (seg)
-    (if *arm2-open-code-inline*
-      (! restore-full-lisp-context)
-      (! restore-full-lisp-context-ool))))
+    (! restore-full-lisp-context)))
 
 (defun arm2-call-symbol (seg jump-p)
@@ -2242,11 +2306,7 @@
   ; tradeoff.
   (with-arm-local-vinsn-macros (seg)
-    (if *arm2-open-code-inline*
       (if jump-p
         (! jump-known-symbol)
-        (! call-known-symbol arm::arg_z))
-      (if jump-p
-        (! jump-known-symbol-ool)
-        (! call-known-symbol-ool)))))
+        (! call-known-symbol arm::arg_z))))
 
 ;;; Nargs = nil -> multiple-value case.
@@ -2361,7 +2421,8 @@
                            (! tail-call-fn-slide)))
                         (t
+                         (! restore-full-lisp-context)
                          (if symp
-                           (! tail-call-sym-vsp)
-                           (! tail-call-fn-vsp)))))))))
+                           (! jump-known-symbol)
+                           (! jump-known-function)))))))))
         ;; The general (funcall) case: we don't know (at compile-time)
         ;; for sure whether we've got a symbol or a (local, constant)
@@ -2678,6 +2739,6 @@
            (same-reg (eq (hard-regspec-value pushed-reg)
                          (hard-regspec-value popped-reg)))
-           (tsp-p (vinsn-attribute-p push-vinsn :tsp)))
-      (when (and tsp-p t)               ; vsp case is harder.
+           (sp-p (vinsn-attribute-p push-vinsn :sp)))
+      (when (and sp-p t)               ; vsp case is harder.
         (unless (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :tsp :discard)
           (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p
@@ -3108,20 +3169,8 @@
          (! compare dest ireg jreg)
          (^ cr-bit true-p))
-       (with-imm-temps () ((b31-reg :natural))
-         (ecase cr-bit
-           (#. arm::arm-cond-eq 
-            (if true-p
-              (! eq->bit31 b31-reg ireg jreg)
-              (! ne->bit31 b31-reg ireg jreg)))
-           (#. arm::arm-cond-lt
-            (if true-p
-              (! lt->bit31 b31-reg ireg jreg)
-              (! ge->bit31 b31-reg ireg jreg)))
-           (#. arm::arm-cond-gt
-            (if true-p
-              (! gt->bit31 b31-reg ireg jreg)
-              (! le->bit31 b31-reg ireg jreg))))
+       (with-crf-target () crf
+         (! compare crf ireg jreg)
          (ensuring-node-target (target dest)
-           (! lowbit->truth target b31-reg))
+           (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
          (^)))
       (^))))
@@ -3135,12 +3184,8 @@
          (! compare-to-nil dest ireg)
          (^ cr-bit true-p))
-       (with-imm-temps () ((b31-reg :natural))
-         (ecase cr-bit
-           (#. arm::arm-cond-eq 
-            (if true-p
-              (! eqnil->bit31 b31-reg ireg)
-              (! nenil->bit31 b31-reg ireg))))
+       (with-crf-target () crf
+         (! compare-to-nil crf ireg)
          (ensuring-node-target (target dest)
-           (! lowbit->truth target b31-reg))
+           (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
          (^)))
       (^))))
@@ -3219,4 +3264,5 @@
     (prog1
       (! vpush-register src)
+      (arm2-regmap-note-store src *arm2-vstack*)
       (arm2-new-vstack-lcell (or why :node) *arm2-target-lcell-size* (or attr 0) info)
       (arm2-adjust-vstack *arm2-target-node-size*))))
@@ -4809,5 +4855,6 @@
          (vp (vinsn-variable-parts vinsn))
          (nvp (vinsn-template-nvp template))
-         (unique-labels ()))
+         (unique-labels ())
+         (operand-insert-functions arm::*arm-vinsn-insert-functions*))
     (declare (fixnum nvp))
     (dotimes (i nvp)
@@ -4820,4 +4867,5 @@
         (arm::make-lap-label unique)))
     (labels ((parse-operand-form (valform)
+               ;(break "valform = ~s" valform)
                (cond ((typep valform 'keyword)
                       (or (assq valform unique-labels)
@@ -4835,14 +4883,19 @@
                             (setq tail (cdr (rplaca tail (parse-operand-form op)))))))))
              (expand-insn-form (f)
-               (let* ((operands (cdr f))
-                      (head (make-list (length operands)))
-                      (tail head))
-                 (declare (dynamic-extent head)
-                          (cons head tail))
-                 (dolist (op operands)
-                   (rplaca tail (parse-operand-form op))
-                   (setq tail (cdr tail)))
-                 (arm-emit-lap-instruction (svref arm::*arm-opcodes* (car f)) 
-                                           head)))
+               (case (car f)
+                 (:code (setq current (svref sections 0)))
+                 (:data (setq current (svref sections 1)))
+                 (:word
+                  (let* ((insn (arm::make-lap-instruction nil)))
+                    (setf (arm::lap-instruction-opcode insn)
+                          (parse-operand-form (cadr f)))
+                    (append-dll-node insn current)))
+                 (t
+                  (let* ((insn (arm::make-lap-instruction nil))
+                         (operands (cdr f)))
+                    (setf (arm::lap-instruction-opcode insn) (car f))
+                    (dolist (op operands (append-dll-node insn current))
+                      (let* ((insert-function (svref operand-insert-functions (car op))))
+                        (funcall insert-function insn (parse-operand-form (cdr op)))))))))
              (eval-predicate (f)
                (case (car f)
@@ -4878,5 +4931,6 @@
       (setf (vinsn-variable-parts vinsn) nil)
       (when vp
-        (free-varparts-vector vp)))))
+        (free-varparts-vector vp))
+      current)))
 
 
@@ -4964,5 +5018,4 @@
            (num-req (length req))
            (num-opt (length (%car opt)))
-           (no-regs nil)
            (arg-regs nil)
            optsupvloc
@@ -4971,7 +5024,6 @@
       (declare (type (unsigned-byte 16) num-req num-opt num-inh))
       (with-arm-p2-declarations p2decls
-        (setq *arm2-inhibit-register-allocation*
-              (setq no-regs (%ilogbitp $fbitnoregs fbits)))
-
+        ;; Need to do this for effect here.
+        (nx2-allocate-global-registers *arm2-fcells* *arm2-vcells* nil nil nil)
         (@ (backend-get-next-label)) ; generic self-reference label, should be label #1
         (when keys ;; Ensure keyvect is the first immediate
@@ -5001,7 +5053,5 @@
                 (unless (or rest keys)
                   (! check-max-nargs (+ num-fixed num-opt)))
-                ;; Going to have to call one or more subprims.  First save
-                ;; the LR in LOC-PC.
-                (! save-lr)
+                (! save-lisp-context-variable)
                 ;; If there were &optional args, initialize their values
                 ;; to NIL.  All of the argregs get vpushed as a result of this.
@@ -5074,8 +5124,5 @@
                        (nbytes-vpushed (* nwords-vpushed *arm2-target-node-size*)))
                   (declare (fixnum nwords-vpushed nbytes-vpushed))
-                  (unless (or lexprp keys) 
-                    (if *arm2-open-code-inline*
-                      (! save-lisp-context-offset nbytes-vpushed)
-                      (! save-lisp-context-offset-ool nbytes-vpushed)))
+
                   (arm2-set-vstack nbytes-vpushed)
                   (setq optsupvloc (- *arm2-vstack* (* num-opt *arm2-target-node-size*)))))))