Index: /branches/arm/compiler/ARM/arm-asm.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-asm.lisp (revision 13762) +++ /branches/arm/compiler/ARM/arm-asm.lisp (revision 13763) @@ -22,5 +22,5 @@ (defparameter *arm-condition-names* '(("eq" . 0) ("ne" . 1) - ("cc" . 2) ("hs" . 2) ("cs" . 3) ("lo" . 3) + ("hs" . 2) ("cc" . 2) ("lo" . 3) ("cs" . 3) ("mi" . 4) ("pl" . 5) ("vs" . 6) ("vc" . 7) @@ -493,9 +493,9 @@ (define-arm-instruction ldrd (:rde :mem8) #x000000d0 - #x0e3000f0 + #x0e1000f0 ()) (define-arm-instruction strd (:rde :mem8) #x000000f0 - #x0e3000f0 + #x0e4000f0 ()) @@ -660,4 +660,12 @@ #x0fbf0fc0 ()) + (define-arm-instruction smull (:rd :rn :rm :rn) + #x0c000090 + #x0ff000f0 + ()) + (define-arm-instruction smulls (:rd :rn :rm :rn) + #x0c000090 + #x0ff000f0 + ()) )) @@ -1053,6 +1061,5 @@ (set-field-value instruction (byte 4 16) (need-arm-gpr rn)) (cond ((atom index) - (set-field-value instruction (byte 4 0) (need-arm-gpr index)) - (set-field-value instruction (byte 25 1) 1)) + (set-field-value instruction (byte 4 0) (need-arm-gpr index))) (t (unless (eq (keywordize (car index)) :$) (error "Invalid index: ~s." index)) @@ -1062,8 +1069,9 @@ (if (< value 0) (setq value (- value)) - (set-field-value instruction (byte 23 1) 1)) + (set-field-value instruction (byte 1 23) 1)) + (set-field-value instruction (byte 1 22) 1) (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value)) (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value))))))) - (set-addressing-mode instruction mode constant-index)))) + (set-addressing-mode instruction mode constant-index)))) (defun parse-dd-operand (form instruction) @@ -1449,5 +1457,6 @@ (error "Unknown operand: ~s" op))))) (if (eq (car op) :apply) - `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op))))))) + `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op))) + (eval op))))) `(,(cadr form) ,@(mapcar #'simplify-operand (cddr form))))) @@ -1522,5 +1531,4 @@ (defun vinsn-parse-m12-operand (avi value vinsn-params) - (when (typep value 'keyword) (setq value `(:@ arm::pc (:$ ,value)))) @@ -1607,5 +1615,5 @@ (add-avi-operand avi (encode-vinsn-field-type :label) addr)) ((arm-subprimitive-name value) - (add-avi-operand avi (encode-vinsn-field-type :label) addr)) + (add-avi-operand avi (encode-vinsn-field-type :label) value)) (t (error "Unknown branch target: ~s." value))))) @@ -1632,6 +1640,6 @@ (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16)) (let* ((constant-index (and (consp index) (eq (car index) :$)))) - (unless constant-index - (set-avi-opcode-field avi (byte 25 1) 1)) + (when constant-index + (set-avi-opcode-field avi (byte 1 22) 1)) (cond ((atom index) (vinsn-arg-or-gpr avi index vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))) @@ -1821,4 +1829,6 @@ (defun vinsn-insert-label-operand (instruction value) (let* ((label (etypecase value + (cons (or (find-lap-label value) + (error "No LAP label for ~s." (car value)))) (lap-label value) (ccl::vinsn-label @@ -1835,5 +1845,8 @@ (defun vinsn-insert-data-label-operand (instruction value) - ) + (let* ((label (if (typep value 'lap-label) value (find-lap-label value)))) + (unless label + (error "Mystery data label: ~s" value)) + (push (cons instruction :mem12) (lap-label-refs label)))) (defun vinsn-insert-dd-operand (instruction value) Index: /branches/arm/compiler/ARM/arm-vinsns.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-vinsns.lisp (revision 13762) +++ /branches/arm/compiler/ARM/arm-vinsns.lisp (revision 13763) @@ -1408,5 +1408,5 @@ (cmp arg0 arg1)) -(define-arm-vinsn compare-signed-s16const (() +(define-arm-vinsn compare-signed-s16const (((crf :crf)) ((arg0 :imm) (imm :s16const)) @@ -1530,5 +1530,22 @@ (stmdb (:! vsp) (arg_z arg_y))) - +(define-arm-vinsn (vpush-argregs :push :node :vsp) (() + ((num-fixed-args :u16const))) + ((:pred = num-fixed-args 0) + (cmp nargs (:$ 0)) + (beq :done)) + ((:pred < num-fixed-args 2) + (cmp nargs (:$ (ash 2 arm::fixnumshift))) + (strlo arg_z (:@! vsp (:$ (- arm::node-size)))) + (stmeq (:! vsp) (arg_z arg_y)) + (stmhi (:! vsp) (arg_z arg_y arg_x)) + :done) + ((:pred = num-fixed-args 2) + (cmp nargs (:$ (ash 2 arm::fixnumshift))) + (stmeq (:! vsp) (arg_z arg_y)) + (stmhi (:! vsp) (arg_z arg_y arg_x))) + ((:pred > num-fixed-args 2) + (stm (:! vsp) (arg_z arg_y arg_x)))) + (define-arm-vinsn (vpop-register :pop :node :vsp) @@ -1725,15 +1742,12 @@ (mvn dest (:$ (:apply lognot intval)))) ((:not (:pred arm::encode-arm-immediate (:apply lognot intval))) - (:section :data) + (:data) :const (:word intval) - (:section :text) + (:code) (ldr dest :const)))) -#+notyet -(define-arm-vinsn (discard-temp-frame :tsp :pop :discard) (() - ()) - (ldr arm::tsp (:@ arm::tsp (:$ 0)))) + @@ -1841,8 +1855,8 @@ (sub allocptr allocptr (:$ (:apply logand #xff - (:apply - - (:apply logand (lognot 7) - (:apply + (+ 7 4) nbytes)) - arm::fulltag-misc)))) + (:apply - + (:apply logand (lognot 7) + (:apply + (+ 7 4) nbytes)) + arm::fulltag-misc)))) ((:pred > (:apply - (:apply logand (lognot 7) @@ -1850,8 +1864,8 @@ arm::fulltag-misc) #xff) (sub allocptr allocptr (:$ (:apply logand #xff00 - (:apply - - (:apply logand (lognot 7) - (:apply + (+ 7 4) nbytes)) - arm::fulltag-misc))))) + (:apply - + (:apply logand (lognot 7) + (:apply + (+ 7 4) nbytes)) + arm::fulltag-misc))))) (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) (cmp allocptr dest) @@ -3284,7 +3298,4 @@ (define-arm-subprim-call-vinsn (destructuring-bind) .SPdestructuring-bind) -(define-arm-subprim-call-vinsn (simple-keywords) .SPsimple-keywords) - -(define-arm-subprim-call-vinsn (keyword-args) .SPkeyword-args) (define-arm-subprim-call-vinsn (keyword-bind) .SPkeyword-bind) @@ -3305,4 +3316,6 @@ (define-arm-subprim-call-vinsn (gvector) .SPgvector) + +(define-arm-subprim-call-vinsn (discard-temp-frame) .SPdiscard_stack_object) (define-arm-vinsn (nth-value :call :subprim-call) (((result :lisp)) Index: /branches/arm/compiler/ARM/arm2.lisp =================================================================== --- /branches/arm/compiler/ARM/arm2.lisp (revision 13762) +++ /branches/arm/compiler/ARM/arm2.lisp (revision 13763) @@ -1,3 +1,3 @@ -;;-*-Mode: LISP; Package: CCL -*- +;;;-*-Mode: LISP; Package: CCL -*- ;;; ;;; Copyright (C) 2010 Clozure Associates @@ -316,39 +316,17 @@ (:GE (values arm::arm-cond-ge t)))) -;;; Generate the start and end bits for a RLWINM instruction that -;;; would be equivalent to to LOGANDing the constant with some value. -;;; Return (VALUES NIL NIL) if the constant contains more than one -;;; sequence of consecutive 1-bits, else bit indices. -;;; The caller generally wants to treat the constant as an (UNSIGNED-BYTE 32); -;;; since this uses LOGCOUNT and INTEGER-LENGTH to find the significant -;;; bits, it ensures that the constant is a (SIGNED-BYTE 32) that has -;;; the same least-significant 32 bits. -(defun arm2-mask-bits (constant) - (if (< constant 0) (setq constant (logand #xffffffff constant))) - (if (= constant #xffffffff) - (values 0 31) - (if (zerop constant) - (values nil nil) - (let* ((signed (if (and (logbitp 31 constant) - (> constant 0)) - (- constant (ash 1 32)) - constant)) - (count (logcount signed)) - (len (integer-length signed)) - (highbit (logbitp (the fixnum (1- len)) constant))) - (declare (fixnum count len)) - (do* ((i 1 (1+ i)) - (pos (- len 2) (1- pos))) - ((= i count) - (let* ((start (- 32 len)) - (end (+ count start))) - (declare (fixnum start end)) - (if highbit - (values start (the fixnum (1- end))) - (values (logand 31 end) - (the fixnum (1- start)))))) - (declare (fixnum i pos)) - (unless (eq (logbitp pos constant) highbit) - (return (values nil nil)))))))) +(defun acode-condition-to-arm-unsigned-cr-bit (cond) + (condition-to-arm-unsigned-cr-bit cond)) + +(defun condition-to-arm-unsigned-cr-bit (cond) + (case cond + (:EQ (values arm::arm-cond-eq t)) + (:NE (values arm::arm-cond-ne t)) + (:GT (values arm::arm-cond-hi t)) + (:LE (values arm::arm-cond-ls t)) + (:LT (values arm::arm-cond-lo t)) + (:GE (values arm::arm-cond-hs t)))) + + @@ -542,7 +520,12 @@ (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) + (memq loc (svref *arm2-gpr-locations* i))) + (when (null (setf (svref *arm2-gpr-locations* i) + (delete loc (svref *arm2-gpr-locations* i)))) + (setq *arm2-gpr-locations-valid-mask* (logandc2 *arm2-gpr-locations-valid-mask* (ash 1 i))))))) + (if (logbitp gpr *arm2-gpr-locations-valid-mask*) + (push loc (svref *arm2-gpr-locations* gpr)) + (setf (svref *arm2-gpr-locations* gpr) (list loc))) + (setq *arm2-gpr-locations-valid-mask* (logior *arm2-gpr-locations-valid-mask* (ash 1 gpr))))) @@ -550,5 +533,7 @@ (defun arm2-regmap-note-reg-location (gpr loc) (let* ((gpr (%hard-regspec-value gpr))) - (setf (svref *arm2-gpr-locations* gpr) loc) + (if (logbitp gpr *arm2-gpr-locations-valid-mask*) + (push loc (svref *arm2-gpr-locations* gpr)) + (setf (svref *arm2-gpr-locations* gpr) (list loc))) (setq *arm2-gpr-locations-valid-mask* (logior *arm2-gpr-locations-valid-mask* (ash 1 gpr))))) @@ -560,6 +545,13 @@ (dotimes (i 16 (setq *arm2-gpr-locations-valid-mask* mask)) (when (logbitp i mask) - (let* ((loc (svref info i))) - (when (>= loc new) + (let* ((locs (svref info i)) + (head (cons nil locs)) + (tail head)) + (declare (dynamic-extent head)) + (dolist (loc locs) + (if (>= loc new) + (setf (cdr tail) (cddr tail)) + (setq tail (cdr tail)))) + (when (null (setf (svref info i) (cdr head))) (setq mask (logandc2 mask (ash 1 i))))))))))) @@ -688,4 +680,5 @@ ;;; to compute/copy than to load it, anyway.) +#+maybe-later-that-same-day (defun arm2-restore-nvrs (seg ea nregs &optional from-fp) (when (null from-fp) @@ -1142,8 +1135,8 @@ (regno (%hard-regspec-value reg))) (unless (and (logbitp regno mask) - (eql offset (svref info regno))) + (memq offset (svref info regno))) (let* ((other (dotimes (i 16) (when (and (logbitp i mask) - (eql offset (svref info i))) + (memq offset (svref info i))) (return i))))) (cond (other @@ -1152,5 +1145,5 @@ (logior mask (ash 1 regno))) (setf (svref info regno) - (svref info other)) + (copy-list (svref info other))) vinsn)) (t @@ -1158,5 +1151,5 @@ (setq *arm2-gpr-locations-valid-mask* (logior mask (ash 1 regno))) - (setf (svref info regno) offset) + (setf (svref info regno) (list offset)) vinsn)))))))) @@ -3171,6 +3164,5 @@ (with-crf-target () crf (! compare crf ireg jreg) - (ensuring-node-target (target dest) - (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1)))) + (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))) (^))) (^)))) @@ -3227,25 +3219,20 @@ (vreg dest) (progn - (! compare-signed-s16const dest reg zero) + (if (or (arm::encode-arm-immediate zero) + (arm::encode-arm-immediate (lognot zero))) + (! compare-signed-s16const dest reg zero) + (with-node-target (reg) other + (arm2-lri seg other zero) + (! compare dest reg other))) (^ cr-bit true-p)) - (with-imm-temps (reg) (b31-reg scaled) - (if (zerop zero) - (setq scaled reg) - (! subtract-constant scaled reg zero)) - (ecase cr-bit - (#. arm::arm-cond-eq - (if true-p - (! eq0->bit31 b31-reg scaled) - (! ne0->bit31 b31-reg scaled))) - (#. arm::arm-cond-lt - (if true-p - (! lt0->bit31 b31-reg scaled) - (! ge0->bit31 b31-reg scaled))) - (#. arm::arm-cond-gt - (if true-p - (! gt0->bit31 b31-reg scaled) - (! le0->bit31 b31-reg scaled)))) - (ensuring-node-target (target dest) - (! lowbit->truth target b31-reg)) + (with-crf-target () crf + (if (or (arm::encode-arm-immediate zero) + (arm::encode-arm-immediate (lognot zero))) + (! compare-signed-s16const crf reg zero) + (with-node-target (reg) other + (arm2-lri seg other zero) + (! compare crf reg other))) + (ensuring-node-target (target dest) + (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1)))) (^))))) @@ -4815,5 +4802,5 @@ (or (eq cd $backend-return) (arm2-mvpass-p cd))) -(defun arm2-expand-note (note header) +(defun arm2-expand-note (header note) (let* ((lab (vinsn-note-label note))) (case (vinsn-note-class note) @@ -5060,4 +5047,6 @@ (! default-optionals (+ num-fixed num-opt))) (when keys + (unless opt + (! vpush-argregs num-fixed)) (let* ((keyvect (%car (%cdr (%cdr (%cdr (%cdr keys)))))) (flags (the fixnum (logior (the fixnum (if rest 4 0)) @@ -5068,14 +5057,8 @@ (dotimes (i (the fixnum (+ nkeys nkeys))) (arm2-new-vstack-lcell :reserved *arm2-target-lcell-size* 0 nil)) - (! misc-ref-c-node arm::temp3 arm::nfn (1+ (backend-immediate-index keyvect))) - (arm2-lri seg arm::imm2 (ash flags *arm2-target-fixnum-shift*)) - (arm2-lri seg arm::imm3 (ash nkeys *arm2-target-fixnum-shift*)) - (unless (= nprev 0) - (arm2-lri seg arm::imm0 (ash nprev *arm2-target-fixnum-shift*))) - (if (= 0 nprev) - (! simple-keywords) - (if (= 0 num-opt) - (! keyword-args) - (! keyword-bind))))) + (backend-immediate-index keyvect) + (arm2-lri seg arm::arg_y (ash flags *arm2-target-fixnum-shift*)) + (arm2-lri seg arm::imm0 (ash nprev *arm2-target-fixnum-shift*)) + (! keyword-bind))) (when rest ;; If any keyword-binding's happened, the key/value @@ -6408,9 +6391,17 @@ (let* ((other (if (and fix1 (typep (ash fix1 *arm2-target-fixnum-shift*) - '(signed-byte 32))) + '(signed-byte 32)) + (or (arm::encode-arm-immediate + (ash fix1 *arm2-target-fixnum-shift*)) + (arm::encode-arm-immediate + (- (ash fix1 *arm2-target-fixnum-shift*))))) form2 (if (and fix2 (typep (ash fix2 *arm2-target-fixnum-shift*) - '(signed-byte 32))) + '(signed-byte 32)) + (or (arm::encode-arm-immediate + (ash fix2 *arm2-target-fixnum-shift*)) + (arm::encode-arm-immediate + (- (ash fix2 *arm2-target-fixnum-shift*))))) form1)))) (if (and fix1 fix2) @@ -6418,18 +6409,9 @@ (if other (let* ((constant (ash (or fix1 fix2) *arm2-target-fixnum-shift*)) - (reg (arm2-one-untargeted-reg-form seg other arm::arg_z)) - (high (ldb (byte 16 16) constant)) - (low (ldb (byte 16 0) constant))) - (declare (fixnum high low)) + (reg (arm2-one-untargeted-reg-form seg other arm::arg_z))) (if (zerop constant) (<- reg) - (progn - (if (logbitp 15 low) (setq high (ldb (byte 16 0) (1+ high)))) - (if (and (eq vreg reg) (not (zerop high))) - (with-node-temps (vreg) (temp) - (! add-immediate temp reg high low) - (<- temp)) - (ensuring-node-target (target vreg) - (! add-immediate target reg high low)))))) + (ensuring-node-target (target vreg) + (! add-immediate target reg constant)))) (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg form1 arm::arg_y form2 arm::arg_z) (ensuring-node-target (target vreg)