[Openmcl-cvs-notifications] r15007 - in /trunk/source/compiler/ARM: arm-asm.lisp arm-vinsns.lisp arm2.lisp
gb at clozure.com
gb at clozure.com
Sat Oct 1 02:00:52 CDT 2011
Author: gb
Date: Sat Oct 1 02:00:52 2011
New Revision: 15007
Log:
arm-asm.lisp: define the canonical (ARMv6T2+) nop instruction.
arm-vinsns.lisp, arm2.lisp: CASE via jumptable sometimes on ARM, too.
Modified:
trunk/source/compiler/ARM/arm-asm.lisp
trunk/source/compiler/ARM/arm-vinsns.lisp
trunk/source/compiler/ARM/arm2.lisp
Modified: trunk/source/compiler/ARM/arm-asm.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/ARM/arm-asm.lisp (original)
+++ trunk/source/compiler/ARM/arm-asm.lisp Sat Oct 1 02:00:52 2011
@@ -202,6 +202,7 @@
#xffa00f10
(:non-conditional))
=
+
;;; UUOs.
=
;;; Nullary UUOs
@@ -332,6 +333,11 @@
(define-arm-instruction movt (:rd :imm16)
#x03400000
#x0ff00000
+ ())
+ ;; This canonical NOP also requires ARMv6T2 or later.
+ (define-arm-instruction nop ()
+ #x0320f000
+ #x0fffffff
())
=
(define-arm-instruction and (:rd :rn :shifter)
Modified: trunk/source/compiler/ARM/arm-vinsns.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/ARM/arm-vinsns.lisp (original)
+++ trunk/source/compiler/ARM/arm-vinsns.lisp Sat Oct 1 02:00:52 2011
@@ -2002,20 +2002,23 @@
((label :label)))
(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 >=3D minval 0)
(:pred < minval #x10000))
@@ -2025,23 +2028,30 @@
(:pred < minval #x10000)))
(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))
(movw temp (:$ maxval)))
((:not (:pred (< maxval #x10000)))
(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))
+
=
=
=
Modified: trunk/source/compiler/ARM/arm2.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/ARM/arm2.lisp (original)
+++ trunk/source/compiler/ARM/arm2.lisp Sat Oct 1 02:00:52 2011
@@ -6361,20 +6361,22 @@
condition))
(t (setf (vinsn-annotation next) condition)))))))))))
=
+(defparameter *arm2-generate-casejump* t)
=
(defun arm2-generate-casejump (seg vreg xfer ranges trueforms var otherwis=
e)
- (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 o=
n 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))
(when (assoc val all)
@@ -6386,41 +6388,57 @@
(setq max val)))
(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 m=
in) 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 i=
nfo (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)
+ (>=3D 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-acod=
e (%nx1-operator lexical-reference) var) arm::arg_z)))
+ (with-imm-target () (idx :u32)
+ (! skip-unless-fixnum-in-range idx reg min span (ar=
ef *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 endlab=
el)
+ (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-sta=
ck)))
(@ 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-st=
ack)
(@ endlabel)
(when (arm2-mvpass-p xfer)
- (^))
- t))))))))))
+ (let* ((*arm2-returning-values* :mvpass))
+ (^)))
+ t))))))))))))
=
=
(defarm2 arm2-if if (seg vreg xfer testform true false &aux test-val)
(if (setq test-val (nx2-constant-form-value (acode-unwrapped-form-value =
testform)))
(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 other=
wise)
(let* ((cstack *arm2-cstack*)
(vstack *arm2-vstack*)
More information about the Openmcl-cvs-notifications
mailing list