Changeset 15007

Timestamp:

Oct 1, 2011, 12:00:52 AM (13 years ago)

Author:

Gary Byers

Message:

arm-asm.lisp: define the canonical (ARMv6T2+) nop instruction.

arm-vinsns.lisp, arm2.lisp: CASE via jumptable sometimes on ARM, too.

Location:

trunk/source/compiler/ARM

Files:

• arm-asm.lisp (modified) (2 diffs)
• arm-vinsns.lisp (modified) (3 diffs)
• arm2.lisp (modified) (3 diffs)

trunk/source/compiler/ARM/arm-asm.lisp

@@ -203 +203 @@
      (:non-conditional))
 
+
 ;;; UUOs.
 
@@ -333 +334 @@
      #x03400000
      #x0ff00000
+     ())
+   ;; This canonical NOP also requires ARMv6T2 or later.
+   (define-arm-instruction nop ()
+     #x0320f000
+     #x0fffffff
      ())
 

trunk/source/compiler/ARM/arm-vinsns.lisp

@@ -2003 +2003 @@
   (b label))
 
-(define-arm-vinsn (cjmp :branch) (((reg :lisp))
-                                  ((reg :lisp)
-                                   (minval :s32const)
-                                   (maxval :u32const)
-                                   (default :label))
-                                  ((temp :s32)))
+
+(define-arm-vinsn (skip-unless-fixnum-in-range :branch)
+    (((idx :u32))
+     ((reg :imm)
+      (minval :s32const)
+      (maxval :u32const)
+      (default :label))
+     ((temp :s32)))
   (tst reg (:$ arm::fixnummask))
+  (mov idx (:asr reg (:$  arm::fixnumshift)))
   (bne default)
   ((:not (:pred zerop minval))
    ((:pred arm::encode-arm-immediate minval)
-    (sub reg reg (:$ minval)))
+    (sub idx idx (:$ minval)))
    ((:not (:pred arm::encode-arm-immediate minval))
     ((:pred arm::encode-arm-immediate (:apply - minval))
-     (add reg reg (:$ (:apply - minval))))
+     (add idx idx (:$ (:apply - minval))))
     ((:not (:pred arm::encode-arm-immediate (:apply - minval)))
      ((:and (:pred >=  minval 0)
@@ -2026 +2029 @@
       (movw temp (:$ (:apply logand #xffff minval)))
       (movt temp (:$ (:apply ldb (byte 16 16) minval))))
-     (sub reg reg temp))))
+     (sub idx idx temp))))
   ((:pred arm::encode-arm-immediate maxval)
-   (cmp reg (:$ maxval)))
+   (cmp idx (:$ maxval)))
   ((:not (:pred arm::encode-arm-immediate maxval))
    ((:pred arm::encode-arm-immediate (:apply lognot maxval))
-    (cmn reg (:$ (:apply lognot maxval))))
+    (cmn idx (:$ (:apply lognot maxval))))
    ((:not (:pred arm::encode-arm-immediate (:apply lognot maxval)))
     ((:pred (< maxval #x10000))
@@ -2038 +2041 @@
      (movw temp (:$ (:apply logand #xffff maxval)))
      (movt temp (:$ (:apply ldb (byte 16 16) maxval))))
-    (cmp reg temp)))
-  (bhi default)
-  (add arm::lr arm::pc reg)
-  (bx lr))
-            
+    (cmp idx temp)))
+  (bhs default))
+
+(define-arm-vinsn (ijmp :branch) (()
+                                  ((idx :u32)))
+  (add arm::pc arm::pc (:lsl idx (:$ 2)))
+  (nop))
+
+(define-arm-vinsn nop (()
+                       ())
+  (nop))
+
 
 

trunk/source/compiler/ARM/arm2.lisp

@@ -6362 +6362 @@
                       (t (setf (vinsn-annotation next) condition)))))))))))
 
+(defparameter *arm2-generate-casejump* t)
 
 (defun arm2-generate-casejump (seg vreg xfer ranges trueforms var otherwise)
-  (declare (ignorable trueforms var otherwise))
-  (with-arm-local-vinsn-macros (seg vreg xfer)
-    (unless (arm2-mvpass-p xfer)
+  (when *arm2-generate-casejump*
+    (with-arm-local-vinsn-macros (seg vreg xfer)
       (when ranges
         (let* ((min (caar ranges))
                (max min)
                (count 0)
-               (all ()))
+               (all ())
+               (labeled-trueforms ()))
           (declare (fixnum min max count))
-          (when ; determine min,max, count; punt on duplicate keys
+          (when                         ; determine min,max, count; punt on duplicate keys
               (dolist (range ranges t)
                 (let* ((info (cons (backend-get-next-label) (pop trueforms))))
+                  (push info labeled-trueforms)
                   (unless (dolist (val range t)
                             (declare (fixnum val))
@@ -6387 +6389 @@
                             (incf count))
                     (return nil))))
-                (let* ((span (1+ (- max min))))
-                  (declare (fixnum span))
-                  (when (and (> count 4)
-                             (> count (the fixnum (- span (the fixnum (ash span -2))))))
-                    (let* ((defaultlabel (backend-get-next-label))
-                           (endlabel (backend-get-next-label))
-                           (reg ($ arm::arg_z)))
-                      (arm2-use-operator (%nx1-operator lexical-reference)
-                                         seg reg nil var)
-                      (! cjmp reg (ash min arm::fixnumshift) (ash (- max min) arm::fixnumshift)  (aref *backend-labels* defaultlabel))
-                      (do* ((val min (1+ val)))
-                           ((> val max))
-                        (declare (fixnum val))
-                        (let* ((info (assoc val all)))
-                          (! non-barrier-jump (aref *backend-labels* (if info (cadr info) defaultlabel)))))
-                      (let* ((target (arm2-cd-merge xfer endlabel)))
-                        (dolist (case (nreverse all))
-                          (let* ((lab (cadr case))
-                                 (form (cddr case)))
+            (let* ((span (1+ (- max min))))
+              (when (and (> count 4)
+                         (>= count (the fixnum (- span (the fixnum (ash span -2))))))
+                (let* ((defaultlabel (backend-get-next-label))
+                       (endlabel (backend-get-next-label))
+                       (single-clause (and (eql count span)
+                                           (eql (length labeled-trueforms) 1))))
+                  (let* ((reg (arm2-one-untargeted-reg-form seg (make-acode (%nx1-operator lexical-reference) var) arm::arg_z)))
+                    (with-imm-target () (idx :u32)
+                      (! skip-unless-fixnum-in-range idx reg min span  (aref *backend-labels* defaultlabel))
+
+                      (unless single-clause
+                        (! ijmp idx)
+                        (do* ((val min (1+ val)))
+                             ((> val max) (! nop))
+                          (declare (fixnum val))
+                          (let* ((info (assoc val all)))
+                            (! non-barrier-jump (aref *backend-labels* (if info (cadr info) defaultlabel))))))
+                      (let* ((target (if (arm2-mvpass-p xfer)
+                                       (logior $backend-mvpass-mask endlabel)
+                                       (arm2-cd-merge xfer endlabel)))
+                             (entry-stack (arm2-encode-stack)))
+                        (dolist (case (nreverse labeled-trueforms))
+                          (let* ((lab (car case))
+                                 (form (cdr case)))
                             (@ lab)
-                            (arm2-form seg vreg target form)))
+                            (multiple-value-setq (*arm2-undo-count*
+                                                  *arm2-cstack*
+                                                  *arm2-vstack*
+                                                  *arm2-top-vstack-lcell*)
+                              (arm2-decode-stack entry-stack))
+                            (arm2-undo-body seg vreg target form entry-stack)))
                         (@ defaultlabel)
-                        (arm2-form seg vreg target otherwise)
+                        (multiple-value-setq (*arm2-undo-count*
+                                              *arm2-cstack*
+                                              *arm2-vstack*
+                                              *arm2-top-vstack-lcell*)
+                          (arm2-decode-stack entry-stack))
+                        (arm2-undo-body seg vreg target otherwise entry-stack)
                         (@ endlabel)
                         (when (arm2-mvpass-p xfer)
-                          (^))
-                        t))))))))))
+                          (let* ((*arm2-returning-values* :mvpass))
+                            (^)))
+                        t))))))))))))
                         
 
@@ -6420 +6439 @@
     (arm2-form seg vreg xfer (if (nx-null test-val) false true))
     (multiple-value-bind (ranges trueforms var otherwise)
-        #+notyet (nx2-reconstruct-case testform true false)
-        #-notyet (values nil nil nil nil)
+        (nx2-reconstruct-case testform true false)
       (or (arm2-generate-casejump seg vreg xfer ranges trueforms var otherwise)
           (let* ((cstack *arm2-cstack*)