Changeset 13751

Timestamp:

May 30, 2010, 2:36:13 PM (9 years ago)

Author:

gb

Message:

Some stuff compiles; still a lot of work to do.
Try to reduce stack traffic in some simple cases by tracking which
registers contain copies of which stack locations. Should try to
exploit this further (and port to other platforms when it's working
reliably.)
Todo: well, a very long list of things, but one that seems obvious
is to try to use predication (at the vinsn level) to reduce the number
of conditional branches.

Location:

branches/arm/compiler/ARM

Files:

• arm-asm.lisp (modified) (19 diffs)
• arm-disassemble.lisp (modified) (1 diff)
• arm-vinsns.lisp (modified) (16 diffs)
• arm2.lisp (modified) (29 diffs)

branches/arm/compiler/ARM/arm-asm.lisp

@@ -277 +277 @@
      ())
    (define-arm-instruction ands (:rd :rn :shifter)
-     #x00100000
+     #x01000000
      ((#x03000000 . #x0ff00000)
       (#x01000000 . #x0ff00010)
@@ -511 +511 @@
    (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 +547 @@
    (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 +916 @@
   (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 +1039 @@
 
 (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 +1247 @@
 
 (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 +1374 @@
     :label
     :subprim
-    :application
-    :local-label
+    :data-label
     :dd
     :dm
@@ -1404 +1414 @@
   (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 +1422 @@
   (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 +1430 @@
   (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 +1455 @@
   (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 +1488 @@
              (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 +1517 @@
            (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 +1565 @@
     (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 +1598 @@
 (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 +1616 @@
   (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 +1623 @@
                         (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 +1717 @@
                                                 (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 +1742 @@
 
 (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")

branches/arm/compiler/ARM/arm-disassemble.lisp

@@ -264 +264 @@
     extract-arm-dn-operand
     extract-arm-sn-operand
+    extract-arm-rd-operand                  ;rde
+    extract-arm-rs-operand
     ))
 

branches/arm/compiler/ARM/arm-vinsns.lisp

@@ -1212 +1212 @@
                                     ((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 +1328 @@
 
 
-;; 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 +1339 @@
   (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 +1524 @@
   (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 +1686 @@
 (define-arm-vinsn (cbranch-true :branch) (()
                                           ((label :label)
+                                           (crf :crf)
                                            (crbit :u8const)))
   (b (:? crbit) label))
@@ -1870 +1692 @@
 (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 +2561 @@
   (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 +2790 @@
 (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 +3201 @@
     (ba ,spno)))
 
-(define-arm-subprim-jump-vinsn (restore-interrupt-level) .SPrestoreintlevel)
 
 (define-arm-subprim-call-vinsn (save-values) .SPsave-values)
@@ -3372 +3208 @@
 (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 +3221 @@
 (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 +3230 @@
 (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 +3239 @@
 (define-arm-subprim-call-vinsn (gets32) .SPgets32)
 
-(define-arm-subprim-call-vinsn (getxlong)  .SPgetXlong)
 
 (define-arm-subprim-call-vinsn (stack-cons-list)  .SPstkconslist)
@@ -3511 +3339 @@
 
 (define-arm-subprim-call-vinsn (mkunwind) .SPmkunwind)
-(define-arm-subprim-call-vinsn (nmkunwind) .SPnmkunwind)
+(define-arm-subprim-call-vinsn (nmkunwind) .SPmkunwind)
 
 
@@ -3518 +3346 @@
 (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 +3363 @@
 
 
-(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)

branches/arm/compiler/ARM/arm2.lisp

@@ -1 @@
-;;;-*-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 +62 @@
                     (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 +117 @@
 (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 +161 @@
 
 (defvar *arm2-result-reg* arm::arg_z)
+(defvar *arm2-gpr-locations* nil)
+(defvar *arm2-gpr-locations-valid-mask* 0)
 
 
@@ -374 +374 @@
            (*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 +395 @@
            (*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 +426 @@
            (*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 +493 @@
     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 +523 @@
               (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 +845 @@
           (! 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 +851 @@
             (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 +1107 @@
 
 (defun arm2-set-vstack (new)
+  (arm2-regmap-note-vstack-delta new *arm2-vstack*)
   (setq *arm2-vstack* new))
 
@@ -1096 +1137 @@
 (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 +1171 @@
 (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 +2293 @@
 (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 +2306 @@
   ; 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 +2421 @@
                            (! 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 +2739 @@
            (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 +3169 @@
          (! 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 +3184 @@
          (! 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 +3264 @@
     (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 +4855 @@
          (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 +4867 @@
         (arm::make-lap-label unique)))
     (labels ((parse-operand-form (valform)
+               ;(break "valform = ~s" valform)
                (cond ((typep valform 'keyword)
                       (or (assq valform unique-labels)
@@ -4835 +4883 @@
                             (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 +4931 @@
       (setf (vinsn-variable-parts vinsn) nil)
       (when vp
-        (free-varparts-vector vp)))))
+        (free-varparts-vector vp))
+      current)))
 
 
@@ -4964 +5018 @@
            (num-req (length req))
            (num-opt (length (%car opt)))
-           (no-regs nil)
            (arg-regs nil)
            optsupvloc
@@ -4971 +5024 @@
       (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 +5053 @@
                 (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 +5124 @@
                        (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*)))))))