Changeset 13763
- Timestamp:
- Jun 1, 2010, 4:22:40 AM (14 years ago)
- Location:
- branches/arm/compiler/ARM
- Files:
-
- 3 edited
-
arm-asm.lisp (modified) (11 diffs)
-
arm-vinsns.lisp (modified) (7 diffs)
-
arm2.lisp (modified) (16 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/arm/compiler/ARM/arm-asm.lisp
r13751 r13763 22 22 23 23 (defparameter *arm-condition-names* '(("eq" . 0) ("ne" . 1) 24 (" cc" . 2) ("hs" . 2) ("cs" . 3) ("lo" . 3)24 ("hs" . 2) ("cc" . 2) ("lo" . 3) ("cs" . 3) 25 25 ("mi" . 4) ("pl" . 5) 26 26 ("vs" . 6) ("vc" . 7) … … 493 493 (define-arm-instruction ldrd (:rde :mem8) 494 494 #x000000d0 495 #x0e 3000f0495 #x0e1000f0 496 496 ()) 497 497 (define-arm-instruction strd (:rde :mem8) 498 498 #x000000f0 499 #x0e 3000f0499 #x0e4000f0 500 500 ()) 501 501 … … 660 660 #x0fbf0fc0 661 661 ()) 662 (define-arm-instruction smull (:rd :rn :rm :rn) 663 #x0c000090 664 #x0ff000f0 665 ()) 666 (define-arm-instruction smulls (:rd :rn :rm :rn) 667 #x0c000090 668 #x0ff000f0 669 ()) 662 670 )) 663 671 … … 1053 1061 (set-field-value instruction (byte 4 16) (need-arm-gpr rn)) 1054 1062 (cond ((atom index) 1055 (set-field-value instruction (byte 4 0) (need-arm-gpr index)) 1056 (set-field-value instruction (byte 25 1) 1)) 1063 (set-field-value instruction (byte 4 0) (need-arm-gpr index))) 1057 1064 (t (unless (eq (keywordize (car index)) :$) 1058 1065 (error "Invalid index: ~s." index)) … … 1062 1069 (if (< value 0) 1063 1070 (setq value (- value)) 1064 (set-field-value instruction (byte 23 1) 1)) 1071 (set-field-value instruction (byte 1 23) 1)) 1072 (set-field-value instruction (byte 1 22) 1) 1065 1073 (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value)) 1066 1074 (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value))))))) 1067 (set-addressing-mode instruction mode constant-index))))1075 (set-addressing-mode instruction mode constant-index)))) 1068 1076 1069 1077 (defun parse-dd-operand (form instruction) … … 1449 1457 (error "Unknown operand: ~s" op))))) 1450 1458 (if (eq (car op) :apply) 1451 `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op))))))) 1459 `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op))) 1460 (eval op))))) 1452 1461 `(,(cadr form) ,@(mapcar #'simplify-operand (cddr form))))) 1453 1462 … … 1522 1531 1523 1532 (defun vinsn-parse-m12-operand (avi value vinsn-params) 1524 1525 1533 (when (typep value 'keyword) 1526 1534 (setq value `(:@ arm::pc (:$ ,value)))) … … 1607 1615 (add-avi-operand avi (encode-vinsn-field-type :label) addr)) 1608 1616 ((arm-subprimitive-name value) 1609 (add-avi-operand avi (encode-vinsn-field-type :label) addr))1617 (add-avi-operand avi (encode-vinsn-field-type :label) value)) 1610 1618 (t 1611 1619 (error "Unknown branch target: ~s." value))))) … … 1632 1640 (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16)) 1633 1641 (let* ((constant-index (and (consp index) (eq (car index) :$)))) 1634 ( unlessconstant-index1635 (set-avi-opcode-field avi (byte 25 1) 1))1642 (when constant-index 1643 (set-avi-opcode-field avi (byte 1 22) 1)) 1636 1644 (cond ((atom index) 1637 1645 (vinsn-arg-or-gpr avi index vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))) … … 1821 1829 (defun vinsn-insert-label-operand (instruction value) 1822 1830 (let* ((label (etypecase value 1831 (cons (or (find-lap-label value) 1832 (error "No LAP label for ~s." (car value)))) 1823 1833 (lap-label value) 1824 1834 (ccl::vinsn-label … … 1835 1845 1836 1846 (defun vinsn-insert-data-label-operand (instruction value) 1837 ) 1847 (let* ((label (if (typep value 'lap-label) value (find-lap-label value)))) 1848 (unless label 1849 (error "Mystery data label: ~s" value)) 1850 (push (cons instruction :mem12) (lap-label-refs label)))) 1838 1851 1839 1852 (defun vinsn-insert-dd-operand (instruction value) -
branches/arm/compiler/ARM/arm-vinsns.lisp
r13751 r13763 1408 1408 (cmp arg0 arg1)) 1409 1409 1410 (define-arm-vinsn compare-signed-s16const (( )1410 (define-arm-vinsn compare-signed-s16const (((crf :crf)) 1411 1411 ((arg0 :imm) 1412 1412 (imm :s16const)) … … 1530 1530 (stmdb (:! vsp) (arg_z arg_y))) 1531 1531 1532 1532 (define-arm-vinsn (vpush-argregs :push :node :vsp) (() 1533 ((num-fixed-args :u16const))) 1534 ((:pred = num-fixed-args 0) 1535 (cmp nargs (:$ 0)) 1536 (beq :done)) 1537 ((:pred < num-fixed-args 2) 1538 (cmp nargs (:$ (ash 2 arm::fixnumshift))) 1539 (strlo arg_z (:@! vsp (:$ (- arm::node-size)))) 1540 (stmeq (:! vsp) (arg_z arg_y)) 1541 (stmhi (:! vsp) (arg_z arg_y arg_x)) 1542 :done) 1543 ((:pred = num-fixed-args 2) 1544 (cmp nargs (:$ (ash 2 arm::fixnumshift))) 1545 (stmeq (:! vsp) (arg_z arg_y)) 1546 (stmhi (:! vsp) (arg_z arg_y arg_x))) 1547 ((:pred > num-fixed-args 2) 1548 (stm (:! vsp) (arg_z arg_y arg_x)))) 1549 1533 1550 1534 1551 (define-arm-vinsn (vpop-register :pop :node :vsp) … … 1725 1742 (mvn dest (:$ (:apply lognot intval)))) 1726 1743 ((:not (:pred arm::encode-arm-immediate (:apply lognot intval))) 1727 (: section :data)1744 (:data) 1728 1745 :const 1729 1746 (:word intval) 1730 (: section :text)1747 (:code) 1731 1748 (ldr dest :const)))) 1732 1749 1733 1750 1734 #+notyet 1735 (define-arm-vinsn (discard-temp-frame :tsp :pop :discard) (() 1736 ()) 1737 (ldr arm::tsp (:@ arm::tsp (:$ 0)))) 1751 1738 1752 1739 1753 … … 1841 1855 1842 1856 (sub allocptr allocptr (:$ (:apply logand #xff 1843 (:apply -1844 (:apply logand (lognot 7)1845 (:apply + (+ 7 4) nbytes))1846 arm::fulltag-misc))))1857 (:apply - 1858 (:apply logand (lognot 7) 1859 (:apply + (+ 7 4) nbytes)) 1860 arm::fulltag-misc)))) 1847 1861 ((:pred > (:apply - 1848 1862 (:apply logand (lognot 7) … … 1850 1864 arm::fulltag-misc) #xff) 1851 1865 (sub allocptr allocptr (:$ (:apply logand #xff00 1852 (:apply -1853 (:apply logand (lognot 7)1854 (:apply + (+ 7 4) nbytes))1855 arm::fulltag-misc)))))1866 (:apply - 1867 (:apply logand (lognot 7) 1868 (:apply + (+ 7 4) nbytes)) 1869 arm::fulltag-misc))))) 1856 1870 (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) 1857 1871 (cmp allocptr dest) … … 3284 3298 (define-arm-subprim-call-vinsn (destructuring-bind) .SPdestructuring-bind) 3285 3299 3286 (define-arm-subprim-call-vinsn (simple-keywords) .SPsimple-keywords)3287 3288 (define-arm-subprim-call-vinsn (keyword-args) .SPkeyword-args)3289 3300 3290 3301 (define-arm-subprim-call-vinsn (keyword-bind) .SPkeyword-bind) … … 3305 3316 3306 3317 (define-arm-subprim-call-vinsn (gvector) .SPgvector) 3318 3319 (define-arm-subprim-call-vinsn (discard-temp-frame) .SPdiscard_stack_object) 3307 3320 3308 3321 (define-arm-vinsn (nth-value :call :subprim-call) (((result :lisp)) -
branches/arm/compiler/ARM/arm2.lisp
r13751 r13763 1 ;; -*-Mode: LISP; Package: CCL -*-1 ;;;-*-Mode: LISP; Package: CCL -*- 2 2 ;;; 3 3 ;;; Copyright (C) 2010 Clozure Associates … … 316 316 (:GE (values arm::arm-cond-ge t)))) 317 317 318 ;;; Generate the start and end bits for a RLWINM instruction that 319 ;;; would be equivalent to to LOGANDing the constant with some value. 320 ;;; Return (VALUES NIL NIL) if the constant contains more than one 321 ;;; sequence of consecutive 1-bits, else bit indices. 322 ;;; The caller generally wants to treat the constant as an (UNSIGNED-BYTE 32); 323 ;;; since this uses LOGCOUNT and INTEGER-LENGTH to find the significant 324 ;;; bits, it ensures that the constant is a (SIGNED-BYTE 32) that has 325 ;;; the same least-significant 32 bits. 326 (defun arm2-mask-bits (constant) 327 (if (< constant 0) (setq constant (logand #xffffffff constant))) 328 (if (= constant #xffffffff) 329 (values 0 31) 330 (if (zerop constant) 331 (values nil nil) 332 (let* ((signed (if (and (logbitp 31 constant) 333 (> constant 0)) 334 (- constant (ash 1 32)) 335 constant)) 336 (count (logcount signed)) 337 (len (integer-length signed)) 338 (highbit (logbitp (the fixnum (1- len)) constant))) 339 (declare (fixnum count len)) 340 (do* ((i 1 (1+ i)) 341 (pos (- len 2) (1- pos))) 342 ((= i count) 343 (let* ((start (- 32 len)) 344 (end (+ count start))) 345 (declare (fixnum start end)) 346 (if highbit 347 (values start (the fixnum (1- end))) 348 (values (logand 31 end) 349 (the fixnum (1- start)))))) 350 (declare (fixnum i pos)) 351 (unless (eq (logbitp pos constant) highbit) 352 (return (values nil nil)))))))) 318 (defun acode-condition-to-arm-unsigned-cr-bit (cond) 319 (condition-to-arm-unsigned-cr-bit cond)) 320 321 (defun condition-to-arm-unsigned-cr-bit (cond) 322 (case cond 323 (:EQ (values arm::arm-cond-eq t)) 324 (:NE (values arm::arm-cond-ne t)) 325 (:GT (values arm::arm-cond-hi t)) 326 (:LE (values arm::arm-cond-ls t)) 327 (:LT (values arm::arm-cond-lo t)) 328 (:GE (values arm::arm-cond-hs t)))) 329 330 353 331 354 332 … … 542 520 (unless (eql i gpr) 543 521 (when (and (logbitp i *arm2-gpr-locations-valid-mask*) 544 (eql loc (svref *arm2-gpr-locations* i))) 545 (setq *arm2-gpr-locations-valid-mask* (logandc2 *arm2-gpr-locations-valid-mask* (ash 1 i)))))) 546 (setf (svref *arm2-gpr-locations* gpr) loc) 522 (memq loc (svref *arm2-gpr-locations* i))) 523 (when (null (setf (svref *arm2-gpr-locations* i) 524 (delete loc (svref *arm2-gpr-locations* i)))) 525 (setq *arm2-gpr-locations-valid-mask* (logandc2 *arm2-gpr-locations-valid-mask* (ash 1 i))))))) 526 (if (logbitp gpr *arm2-gpr-locations-valid-mask*) 527 (push loc (svref *arm2-gpr-locations* gpr)) 528 (setf (svref *arm2-gpr-locations* gpr) (list loc))) 529 547 530 (setq *arm2-gpr-locations-valid-mask* (logior *arm2-gpr-locations-valid-mask* (ash 1 gpr))))) 548 531 … … 550 533 (defun arm2-regmap-note-reg-location (gpr loc) 551 534 (let* ((gpr (%hard-regspec-value gpr))) 552 (setf (svref *arm2-gpr-locations* gpr) loc) 535 (if (logbitp gpr *arm2-gpr-locations-valid-mask*) 536 (push loc (svref *arm2-gpr-locations* gpr)) 537 (setf (svref *arm2-gpr-locations* gpr) (list loc))) 553 538 (setq *arm2-gpr-locations-valid-mask* (logior *arm2-gpr-locations-valid-mask* (ash 1 gpr))))) 554 539 … … 560 545 (dotimes (i 16 (setq *arm2-gpr-locations-valid-mask* mask)) 561 546 (when (logbitp i mask) 562 (let* ((loc (svref info i))) 563 (when (>= loc new) 547 (let* ((locs (svref info i)) 548 (head (cons nil locs)) 549 (tail head)) 550 (declare (dynamic-extent head)) 551 (dolist (loc locs) 552 (if (>= loc new) 553 (setf (cdr tail) (cddr tail)) 554 (setq tail (cdr tail)))) 555 (when (null (setf (svref info i) (cdr head))) 564 556 (setq mask (logandc2 mask (ash 1 i))))))))))) 565 557 … … 688 680 ;;; to compute/copy than to load it, anyway.) 689 681 682 #+maybe-later-that-same-day 690 683 (defun arm2-restore-nvrs (seg ea nregs &optional from-fp) 691 684 (when (null from-fp) … … 1142 1135 (regno (%hard-regspec-value reg))) 1143 1136 (unless (and (logbitp regno mask) 1144 ( eqloffset (svref info regno)))1137 (memq offset (svref info regno))) 1145 1138 (let* ((other (dotimes (i 16) 1146 1139 (when (and (logbitp i mask) 1147 ( eqloffset (svref info i)))1140 (memq offset (svref info i))) 1148 1141 (return i))))) 1149 1142 (cond (other … … 1152 1145 (logior mask (ash 1 regno))) 1153 1146 (setf (svref info regno) 1154 ( svref info other))1147 (copy-list (svref info other))) 1155 1148 vinsn)) 1156 1149 (t … … 1158 1151 (setq *arm2-gpr-locations-valid-mask* 1159 1152 (logior mask (ash 1 regno))) 1160 (setf (svref info regno) offset)1153 (setf (svref info regno) (list offset)) 1161 1154 vinsn)))))))) 1162 1155 … … 3171 3164 (with-crf-target () crf 3172 3165 (! compare crf ireg jreg) 3173 (ensuring-node-target (target dest) 3174 (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1)))) 3166 (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))) 3175 3167 (^))) 3176 3168 (^)))) … … 3227 3219 (vreg dest) 3228 3220 (progn 3229 (! compare-signed-s16const dest reg zero) 3221 (if (or (arm::encode-arm-immediate zero) 3222 (arm::encode-arm-immediate (lognot zero))) 3223 (! compare-signed-s16const dest reg zero) 3224 (with-node-target (reg) other 3225 (arm2-lri seg other zero) 3226 (! compare dest reg other))) 3230 3227 (^ cr-bit true-p)) 3231 (with-imm-temps (reg) (b31-reg scaled) 3232 (if (zerop zero) 3233 (setq scaled reg) 3234 (! subtract-constant scaled reg zero)) 3235 (ecase cr-bit 3236 (#. arm::arm-cond-eq 3237 (if true-p 3238 (! eq0->bit31 b31-reg scaled) 3239 (! ne0->bit31 b31-reg scaled))) 3240 (#. arm::arm-cond-lt 3241 (if true-p 3242 (! lt0->bit31 b31-reg scaled) 3243 (! ge0->bit31 b31-reg scaled))) 3244 (#. arm::arm-cond-gt 3245 (if true-p 3246 (! gt0->bit31 b31-reg scaled) 3247 (! le0->bit31 b31-reg scaled)))) 3248 (ensuring-node-target (target dest) 3249 (! lowbit->truth target b31-reg)) 3228 (with-crf-target () crf 3229 (if (or (arm::encode-arm-immediate zero) 3230 (arm::encode-arm-immediate (lognot zero))) 3231 (! compare-signed-s16const crf reg zero) 3232 (with-node-target (reg) other 3233 (arm2-lri seg other zero) 3234 (! compare crf reg other))) 3235 (ensuring-node-target (target dest) 3236 (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1)))) 3250 3237 (^))))) 3251 3238 … … 4815 4802 (or (eq cd $backend-return) (arm2-mvpass-p cd))) 4816 4803 4817 (defun arm2-expand-note ( note header)4804 (defun arm2-expand-note (header note) 4818 4805 (let* ((lab (vinsn-note-label note))) 4819 4806 (case (vinsn-note-class note) … … 5060 5047 (! default-optionals (+ num-fixed num-opt))) 5061 5048 (when keys 5049 (unless opt 5050 (! vpush-argregs num-fixed)) 5062 5051 (let* ((keyvect (%car (%cdr (%cdr (%cdr (%cdr keys)))))) 5063 5052 (flags (the fixnum (logior (the fixnum (if rest 4 0)) … … 5068 5057 (dotimes (i (the fixnum (+ nkeys nkeys))) 5069 5058 (arm2-new-vstack-lcell :reserved *arm2-target-lcell-size* 0 nil)) 5070 (! misc-ref-c-node arm::temp3 arm::nfn (1+ (backend-immediate-index keyvect))) 5071 (arm2-lri seg arm::imm2 (ash flags *arm2-target-fixnum-shift*)) 5072 (arm2-lri seg arm::imm3 (ash nkeys *arm2-target-fixnum-shift*)) 5073 (unless (= nprev 0) 5074 (arm2-lri seg arm::imm0 (ash nprev *arm2-target-fixnum-shift*))) 5075 (if (= 0 nprev) 5076 (! simple-keywords) 5077 (if (= 0 num-opt) 5078 (! keyword-args) 5079 (! keyword-bind))))) 5059 (backend-immediate-index keyvect) 5060 (arm2-lri seg arm::arg_y (ash flags *arm2-target-fixnum-shift*)) 5061 (arm2-lri seg arm::imm0 (ash nprev *arm2-target-fixnum-shift*)) 5062 (! keyword-bind))) 5080 5063 (when rest 5081 5064 ;; If any keyword-binding's happened, the key/value … … 6408 6391 (let* ((other (if (and fix1 6409 6392 (typep (ash fix1 *arm2-target-fixnum-shift*) 6410 '(signed-byte 32))) 6393 '(signed-byte 32)) 6394 (or (arm::encode-arm-immediate 6395 (ash fix1 *arm2-target-fixnum-shift*)) 6396 (arm::encode-arm-immediate 6397 (- (ash fix1 *arm2-target-fixnum-shift*))))) 6411 6398 form2 6412 6399 (if (and fix2 6413 6400 (typep (ash fix2 *arm2-target-fixnum-shift*) 6414 '(signed-byte 32))) 6401 '(signed-byte 32)) 6402 (or (arm::encode-arm-immediate 6403 (ash fix2 *arm2-target-fixnum-shift*)) 6404 (arm::encode-arm-immediate 6405 (- (ash fix2 *arm2-target-fixnum-shift*))))) 6415 6406 form1)))) 6416 6407 (if (and fix1 fix2) … … 6418 6409 (if other 6419 6410 (let* ((constant (ash (or fix1 fix2) *arm2-target-fixnum-shift*)) 6420 (reg (arm2-one-untargeted-reg-form seg other arm::arg_z)) 6421 (high (ldb (byte 16 16) constant)) 6422 (low (ldb (byte 16 0) constant))) 6423 (declare (fixnum high low)) 6411 (reg (arm2-one-untargeted-reg-form seg other arm::arg_z))) 6424 6412 (if (zerop constant) 6425 6413 (<- reg) 6426 (progn 6427 (if (logbitp 15 low) (setq high (ldb (byte 16 0) (1+ high)))) 6428 (if (and (eq vreg reg) (not (zerop high))) 6429 (with-node-temps (vreg) (temp) 6430 (! add-immediate temp reg high low) 6431 (<- temp)) 6432 (ensuring-node-target (target vreg) 6433 (! add-immediate target reg high low)))))) 6414 (ensuring-node-target (target vreg) 6415 (! add-immediate target reg constant)))) 6434 6416 (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg form1 arm::arg_y form2 arm::arg_z) 6435 6417 (ensuring-node-target (target vreg)
Note:
See TracChangeset
for help on using the changeset viewer.
