Changeset 14042
- Timestamp:
- Jul 25, 2010, 8:59:17 PM (11 years ago)
- Location:
- branches/arm/compiler/ARM
- Files:
-
- 3 edited
-
arm-asm.lisp (modified) (17 diffs)
-
arm-lap.lisp (modified) (5 diffs)
-
arm2.lisp (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/arm/compiler/ARM/arm-asm.lisp
r14033 r14042 895 895 (:constructor %make-lap-instruction (source))) 896 896 source ; for LAP, maybe vinsn-template 897 (opcode 0)898 vinsn-info ;tbd897 (opcode-high 0) 898 (opcode-low 0) 899 899 ) 900 900 … … 909 909 910 910 911 (eval-when (:compile-toplevel :execute) 912 (declaim (inline set-field-value))) 911 (defun set-opcode-values (high low bytespec value) 912 (declare (type (unsigned-byte 16) low high)) 913 (let* ((width (byte-size bytespec)) 914 (pos (byte-position bytespec))) 915 (declare (type (unsigned-byte 5) width pos)) 916 (cond ((<= (the fixnum (+ width pos)) 16) 917 (values high (dpb value bytespec low))) 918 ((>= pos 16) 919 (values (dpb value (byte width (- pos 16)) high) low)) 920 ;; Branch displacements are about the only things 921 ;; that span the two halves of an instruction. 922 (t 923 (let* ((low-width (- 16 pos)) 924 (high-width (- width low-width))) 925 (declare (fixnum low-width high-width)) 926 (values (dpb (ldb (byte high-width low-width) value) 927 (byte high-width 0) 928 high) 929 (dpb (ldb (byte low-width 0) value) 930 (byte low-width pos) 931 low))))))) 913 932 914 933 (defun set-field-value (instruction bytespec value) 915 (setf (lap-instruction-opcode instruction) 916 (dpb value bytespec (lap-instruction-opcode instruction)))) 934 (let* ((low (lap-instruction-opcode-low instruction)) 935 (high (lap-instruction-opcode-high instruction))) 936 (declare (type (unsigned-byte 16) low high)) 937 (multiple-value-bind (new-high new-low) 938 (set-opcode-values high low bytespec value) 939 (declare (type (unsigned-byte 16) new-low new-high)) 940 (unless (eql low new-low) 941 (setf (lap-instruction-opcode-low instruction) new-low)) 942 (unless (eql high new-high) 943 (setf (lap-instruction-opcode-high instruction) new-high))))) 944 945 946 (defun get-opcode-field (high low bytespec) 947 (declare (fixnum high low)) 948 (let* ((width (byte-size bytespec)) 949 (pos (byte-position bytespec))) 950 (declare (fixnum width pos)) 951 (cond ((<= (the fixnum (+ width pos)) 16) 952 (ldb bytespec low)) 953 ((>= pos 16) 954 (ldb (byte width (- pos 16)) high)) 955 ;; Branch displacements are about the only things 956 ;; that span the two halves of an instruction. 957 (t 958 (let* ((low-width (- 16 pos)) 959 (high-width (- width low-width))) 960 (declare (fixnum low-width high-width)) 961 (dpb (ldb (byte high-width 0) high) 962 (byte high-width low-width) 963 (ldb (byte low-width pos) low))))))) 964 965 (defun get-field-value (instruction bytespec) 966 (get-opcode-field (lap-instruction-opcode-high instruction) 967 (lap-instruction-opcode-low instruction) 968 bytespec)) 917 969 918 970 … … 1030 1082 1031 1083 (defun insert-shifter-constant (value instruction) 1032 (let* ((opcode (lap-instruction-opcode instruction)) 1033 (constant (encode-arm-immediate value))) 1034 (setf (lap-instruction-opcode instruction) 1035 (if constant 1036 (logior constant (logior (ash 1 25) opcode)) 1037 ;; If value couldn't be encoded but its complement can be 1038 ;; and there's an instruction that can operate on complemented 1039 ;; values, change the instruction and encode the complemented 1040 ;; value. If that doesn't work, try negating the value and 1041 ;; seeing if there's an equivalent instruction that could use 1042 ;; that. If none of this works, complain that the value can't 1043 ;; be encoded. 1044 (let* ((op (ldb (byte 4 21) opcode)) 1045 (newop nil)) 1046 (if (or (and (setq constant (encode-arm-immediate (lognot value))) 1047 (setq newop (svref *equivalent-complemented-opcodes* op))) 1048 (and (setq constant (encode-arm-immediate (- value))) 1049 (setq newop (svref *equivalent-negated-opcodes* op)))) 1050 (logior constant 1051 (logior (ash 1 25) (dpb newop (byte 4 21) opcode))) 1052 (error "Can't encode ARM constant ~s." value))))))) 1053 1054 (defun set-opcode-value-from-addressing-mode (opcode mode constant-index) 1084 (let* ((constant (encode-arm-immediate value))) 1085 (cond (constant 1086 (set-field-value instruction (byte 12 0) constant) 1087 (set-field-value instruction (byte 1 25) 1)) 1088 (t 1089 ;; If value couldn't be encoded but its complement can be 1090 ;; and there's an instruction that can operate on complemented 1091 ;; values, change the instruction and encode the complemented 1092 ;; value. If that doesn't work, try negating the value and 1093 ;; seeing if there's an equivalent instruction that could use 1094 ;; that. If none of this works, complain that the value can't 1095 ;; be encoded. 1096 (let* ((op (get-field-value instruction (byte 4 21))) 1097 (newop nil)) 1098 (if (or (and (setq constant (encode-arm-immediate (lognot value))) 1099 (setq newop (svref *equivalent-complemented-opcodes* op))) 1100 (and (setq constant (encode-arm-immediate (- value))) 1101 (setq newop (svref *equivalent-negated-opcodes* op)))) 1102 (progn 1103 (set-field-value instruction (byte 1 25) 1) 1104 (set-field-value instruction (byte 12 0) constant) 1105 (set-field-value instruction (byte 4 21) newop)) 1106 (error "Can't encode ARM constant ~s." value))))))) 1107 1108 (defun set-opcode-value-from-addressing-mode (high mode constant-index) 1055 1109 ;; Look at mode and set P/W/U bits. If CONSTANT-INDEX is 1056 1110 ;; true, the U bit depends on the sign of the constant. … … 1059 1113 ;; Preindexed, no writeback unless :[+]@! , add register operands. 1060 1114 (unless constant-index 1061 (setq opcode (logior opcode (ash 1 23))))1115 (setq high (logior high (ash 1 (- 23 16))))) 1062 1116 (when (or (eq mode :+@!) 1063 1117 (eq mode :@!)) 1064 (setq opcode (logior opcode (ash 1 21))))1065 (setq opcode (logior opcode (ash 1 24))))1118 (setq high (logior high (ash 1 (- 21 16))))) 1119 (setq high (logior high (ash 1 (- 24 16))))) 1066 1120 ((:-@ :-@!) 1067 1121 ;; Preindexed. Leave the U bit clear, maybe set W if writeback. 1068 1122 (when (eq mode :-@!) 1069 (setq opcode (logior opcode (ash 1 21))))1070 (setq opcode (logior opcode (ash 1 24))))1123 (setq high (logior high (ash 1 (- 21 16))))) 1124 (setq high (logior high (ash 1 (- 24 16))))) 1071 1125 ((:@+ :@-) 1072 1126 ;; Postindex; writeback is implicit (and setting P and W would 1073 1127 ;; change the instruction.) 1074 1128 (unless (or (eq mode :@-) constant-index) 1075 (setq opcode (logior opcode (ash 1 23))))))1076 opcode)1129 (setq high (logior high (ash 1 (- 23 16))))))) 1130 high) 1077 1131 1078 1132 1079 1133 (defun set-addressing-mode (instruction mode constant-index) 1080 (setf (lap-instruction-opcode instruction)1134 (setf (lap-instruction-opcode-high instruction) 1081 1135 (set-opcode-value-from-addressing-mode 1082 (lap-instruction-opcode instruction) mode constant-index))) 1136 (lap-instruction-opcode-high instruction) 1137 mode 1138 constant-index))) 1139 1083 1140 1084 1141 ;;; "general" address operand, as used in LDR/LDRB/STR/STRB … … 1326 1383 (setf (lap-instruction-source insn) form 1327 1384 (lap-instruction-address insn) nil 1328 (lap-instruction- vinsn-info insn) nil1329 (lap-instruction-opcode insn) nil)1385 (lap-instruction-opcode-low insn) 0 1386 (lap-instruction-opcode-high insn) 0) 1330 1387 insn) 1331 1388 (%make-lap-instruction form)))) … … 1368 1425 (unless (= n (length opvals)) 1369 1426 (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form)) 1370 (setf (lap-instruction-opcode insn) 1371 (arm-instruction-template-val template)) 1427 (set-field-value insn (byte 32 0) (arm-instruction-template-val template)) 1372 1428 (dotimes (i n) 1373 1429 (let* ((optype (pop optypes)) … … 1375 1431 (funcall (svref *arm-operand-parsers* optype) val insn))) 1376 1432 (when cond 1377 (setf (lap-instruction-opcode insn) 1378 (dpb cond (byte 4 28) (lap-instruction-opcode insn)))) 1433 (set-field-value insn (byte 4 28) cond)) 1379 1434 (emit-lap-instruction-element insn seg)))))) 1380 1435 … … 1473 1528 (offset-label (make-lap-label (gensym)))) 1474 1529 (assemble-instruction primary `(b ,target-name)) 1475 (set f (lap-instruction-opcode origin) 0)1530 (set-field-value origin (byte 32 0) 0) 1476 1531 (emit-lap-instruction-element origin primary) 1477 1532 (setq *last-constant-pool-origin* origin) 1478 (set f (lap-instruction-opcode offset) 0)1533 (set-field-value offset (byte 32 0) 0) 1479 1534 (emit-lap-instruction-element offset primary) 1480 (setf (lap-instruction-opcode pool-count) 1481 (ash n-constant-bytes (- arm::word-shift))) 1535 (set-field-value pool-count (byte 32 0) (ash n-constant-bytes (- arm::word-shift))) 1482 1536 (emit-lap-instruction-element pool-count primary) 1483 1537 (ccl::do-dll-nodes (datum constant-pool) … … 1508 1562 (unless (eql constants-size 0) 1509 1563 (let* ((c0 (make-lap-instruction nil))) 1510 (set f (lap-instruction-opcode c0) (ash constants-size -2))1564 (set-field-value c0 (byte 32 0) (ash constants-size -2)) 1511 1565 (ccl::insert-dll-node-before c0 (ccl::dll-header-first constant-pool))))) 1512 1566 (let* ((w0 (make-lap-instruction nil)) 1513 1567 (w1 (make-lap-instruction nil))) 1514 (set f (lap-instruction-opcode w0) 0)1568 (set-field-value w0 (byte 32 0) 0) 1515 1569 (ccl::append-dll-node w0 primary) 1516 1570 (ccl::append-dll-node w1 primary ) 1517 1571 (let* ((n (set-element-addresses 0 primary))) 1518 (set f (lap-instruction-opcode w1) (ash n (- arm::word-shift)))1572 (set-field-value w1 (byte 32 0) (ash n (- arm::word-shift))) 1519 1573 (set-element-addresses n constant-pool))) 1520 1574 ;; Now fix up label references. Recall that the PC value at some … … 1527 1581 (let* ((diff-in-bytes (- labaddr (+ 8 (lap-instruction-address insn))))) 1528 1582 (case reftype 1529 (:b (setf (lap-instruction-opcode insn) 1530 (dpb (ash diff-in-bytes -2) 1531 (byte 24 0) 1532 (lap-instruction-opcode insn)))) 1583 (:b (set-field-value insn (byte 24 0) (ash diff-in-bytes -2))) 1533 1584 (:mem12 1534 1585 (if (>= diff-in-bytes 0) … … 1539 1590 (set-field-value insn (byte 12 0) diff-in-bytes)) 1540 1591 (:offset 1541 (setf (lap-instruction-opcode insn) 1542 (1+ (ash (lap-instruction-address insn) (- arm::word-shift))))) 1592 (set-field-value insn (byte 32 0)(1+ (ash (lap-instruction-address insn) (- arm::word-shift))))) 1543 1593 (t 1544 1594 (error "Label type ~s invalid or not yet supported." … … 1586 1636 1587 1637 (defun make-arm-vinsn-instruction (opcode) 1588 (let* ((head (list opcode))) 1638 (let* ((head (list (cons (ldb (byte 16 16) opcode) 1639 (ldb (byte 16 0) opcode))))) 1589 1640 (%make-arm-vinsn-instruction :head head :tail head))) 1590 1641 … … 1597 1648 (car (avi-head avi))) 1598 1649 1599 (defun (setf avi-opcode) (new avi)1600 (setf (car (avi-head avi)) new))1601 1650 1602 1651 (defun set-avi-opcode-field (avi bytespec value) 1603 (setf (avi-opcode avi) 1604 (dpb value bytespec (avi-opcode avi))) 1605 value) 1652 (let* ((opcode (avi-opcode avi))) 1653 (multiple-value-bind (high low) 1654 (set-opcode-values (car opcode) (cdr opcode) bytespec value) 1655 (declare (type (unsigned-byte 16) high low)) 1656 (setf (car opcode) high 1657 (cdr opcode) low)) 1658 value)) 1659 1660 (defun get-avi-opcode-field (avi bytespec) 1661 (let* ((opcode (avi-opcode avi))) 1662 (get-opcode-field (car opcode) (cdr opcode) bytespec))) 1606 1663 1607 1664 … … 1750 1807 (set-avi-opcode-field avi (byte 1 25) 1) 1751 1808 (set-avi-opcode-field avi (byte 12 0) constant)) 1752 (let* ((op ( ldb (byte 4 21) (avi-opcode avi)))1809 (let* ((op (get-avi-opcode-field avi (byte 4 21))) 1753 1810 (newop nil)) 1754 1811 (if (or (and (setq constant (encode-arm-immediate (lognot val))) … … 1816 1873 (destructuring-bind (shift-count-form) (cdr shift-count) 1817 1874 (vinsn-arg-or-constant avi shift-count-form vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7)))))) 1818 (setf (avi-opcode avi) 1819 (set-opcode-value-from-addressing-mode (avi-opcode avi) op constant-index))))) 1875 (let* ((opcode (avi-opcode avi))) 1876 (setf (car opcode) 1877 (the (unsigned-byte 16) 1878 (set-opcode-value-from-addressing-mode 1879 (car opcode) 1880 op 1881 constant-index))))))) 1820 1882 1821 1883 (defun vinsn-parse-reglist-operand (avi value vinsn-params) … … 1825 1887 (add-avi-operand avi (encode-vinsn-field-type :reglist-bit) (list p)) 1826 1888 (let* ((bit (need-arm-gpr r))) 1827 (setf (avi-opcode avi) 1828 (logior (avi-opcode avi) (ash 1 bit)))))))) 1889 (set-avi-opcode-field avi (byte 1 bit) 1)))))) 1829 1890 1830 1891 (defun vinsn-parse-rnw-operand (avi value vinsn-params) … … 1932 1993 (destructuring-bind (shift-count-form) (cdr shift-count) 1933 1994 (vinsn-arg-or-constant avi shift-count-form vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7)))))) 1934 (setf (avi-opcode avi) 1935 (set-opcode-value-from-addressing-mode (avi-opcode avi) mode constant-index)))))) 1995 (setf (car (avi-opcode avi)) 1996 (the (unsigned-byte 16) 1997 (set-opcode-value-from-addressing-mode (car (avi-opcode avi)) mode constant-index))))))) 1998 1999 1936 2000 1937 2001 (defun vinsn-parse-dd-operand (avi value vinsn-params) -
branches/arm/compiler/ARM/arm-lap.lisp
r13981 r14042 85 85 86 86 87 87 #+big-endian-host 88 (defun set-arm-code-vector-word (code-vector i insn) 89 (setf (uvref code-vector i) 90 (logior (ash (arm::lap-instruction-opcode-high insn) 16) 91 (arm::lap-instruction-opcode-low insn)))) 92 93 #+little-endian-host 94 (defun set-arm-code-vector-word (code-vector i insn) 95 (declare (type (simple-array (unsigned-byte 16) (*)) code-vector) 96 (fixnum i) 97 (optimize (speed 3) (safety 0))) 98 (let* ((j (+ i i))) 99 (declare (fixnum j)) 100 (setf (aref code-vector j) (arm::lap-instruction-opcode-low insn) 101 (aref code-vector (the fixnum (1+ j))) 102 (arm::lap-instruction-opcode-high insn)))) 103 104 88 105 89 106 … … 110 127 (do-dll-nodes (insn seg) 111 128 (unless (eql (arm::instruction-element-size insn) 0) 112 (set f (uvref code-vector i) (arm::lap-instruction-opcode insn))129 (set-arm-code-vector-word code-vector i insn) 113 130 (incf i))) 114 131 (dolist (immpair arm::*arm-constants*) … … 142 159 (arm::emit-lap-instruction-element 143 160 (let* ((insn (arm::make-lap-instruction nil))) 144 ( setf (arm::lap-instruction-opcode insn)(logand #xffffffff (eval arg)))161 (arm::set-field-value insn (byte 32 0) (logand #xffffffff (eval arg))) 145 162 insn) 146 163 current)) … … 148 165 (:single 149 166 (check-usage :single) 150 (a ppend-dll-node167 (arm::emit-lap-instruction-element 151 168 (let* ((insn (arm::make-lap-instruction nil))) 152 ( setf (arm::lap-instruction-opcode insn) (single-float-bits (float (eval arg) 0.0f0)))169 (arm::set-field-value insn (byte 32 0) (single-float-bits (float (eval arg) 0.0f0))) 153 170 insn) 154 171 current)) … … 158 175 (let* ((insnlow (arm::make-lap-instruction nil)) 159 176 (insnhigh (arm::make-lap-instruction nil))) 160 ( setf (arm::lap-instruction-opcode insnlow) low161 (arm::lap-instruction-opcode insnhigh) high)162 (a ppend-dll-nodeinsnlow current)163 (a ppend-dll-nodeinsnhigh current)))))177 (arm::set-field-value insnlow (byte 32 0) low) 178 (arm::set-field-value insnhigh (byte 32 0) high) 179 (arm::emit-lap-instruction-element insnlow current) 180 (arm::emit-lap-instruction-element insnhigh current))))) 164 181 current)) 165 182 -
branches/arm/compiler/ARM/arm2.lisp
r14036 r14042 4908 4908 (:data (setq current (svref sections 1))) 4909 4909 (:word 4910 (let* ((insn (arm::make-lap-instruction nil)) )4911 (setf (arm::lap-instruction-opcode insn)4912 (parse-operand-form (cadr f)))4910 (let* ((insn (arm::make-lap-instruction nil)) 4911 (val (parse-operand-form (cadr f)))) 4912 (arm::set-field-value insn (byte 32 0) val) 4913 4913 (arm::emit-lap-instruction-element insn current))) 4914 4914 (t 4915 4915 (let* ((insn (arm::make-lap-instruction nil)) 4916 (opcode (car f)) 4916 4917 (operands (cdr f))) 4917 (setf (arm::lap-instruction-opcode insn) (car f)) 4918 (setf (arm::lap-instruction-opcode-high insn) (car opcode) 4919 (arm::lap-instruction-opcode-low insn) (cdr opcode)) 4918 4920 (when predicate 4919 4921 (funcall (svref operand-insert-functions … … 4946 4948 (if (atom f) 4947 4949 (compiler-bug "Invalid form in vinsn body: ~s" f) 4948 (if (atom (car f)) 4950 (if (or (atom (car f)) 4951 (typep (caar f) 'fixnum)) 4949 4952 (expand-insn-form f) 4950 4953 (if (eval-predicate (car f))
Note: See TracChangeset
for help on using the changeset viewer.
