Index: /trunk/source/compiler/ARM/arm-asm.lisp =================================================================== --- /trunk/source/compiler/ARM/arm-asm.lisp (revision 15006) +++ /trunk/source/compiler/ARM/arm-asm.lisp (revision 15007) @@ -203,4 +203,5 @@ (:non-conditional)) + ;;; UUOs. @@ -333,4 +334,9 @@ #x03400000 #x0ff00000 + ()) + ;; This canonical NOP also requires ARMv6T2 or later. + (define-arm-instruction nop () + #x0320f000 + #x0fffffff ()) Index: /trunk/source/compiler/ARM/arm-vinsns.lisp =================================================================== --- /trunk/source/compiler/ARM/arm-vinsns.lisp (revision 15006) +++ /trunk/source/compiler/ARM/arm-vinsns.lisp (revision 15007) @@ -2003,18 +2003,21 @@ (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,10 +2029,10 @@ (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,9 +2041,16 @@ (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)) + Index: /trunk/source/compiler/ARM/arm2.lisp =================================================================== --- /trunk/source/compiler/ARM/arm2.lisp (revision 15006) +++ /trunk/source/compiler/ARM/arm2.lisp (revision 15007) @@ -6362,18 +6362,20 @@ (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,31 +6389,48 @@ (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,6 +6439,5 @@ (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*)