Changeset 13741
- Timestamp:
- May 27, 2010, 11:50:14 PM (11 years ago)
- Location:
- branches/arm/compiler/ARM
- Files:
-
- 7 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/arm/compiler/ARM/arm-arch.lisp
r13715 r13741 37 37 (let* ((value (get-arm-register name))) 38 38 (and value (< value 16) value))) 39 39 40 (defun get-arm-sfpr (name) 41 (let* ((value (get-arm-register name))) 42 (and value (logbitp 5 value) (logand #x1f value)))) 43 44 (defun get-arm-dfpr (name) 45 (let* ((value (get-arm-register name))) 46 (and value (logbitp 6 value) (logand #x0f value)))) 47 40 48 41 49 ;;; This allows redefinition, which might be helpful while … … 96 104 (defarmgpr pc r15) 97 105 106 107 98 108 ;;; Calling sequence may pass additional arguments in temp registers. 99 109 ;;; "nfn" (new function) is always passed; it's the new value of "fn". … … 107 117 (defarmgpr nargs imm2) 108 118 119 (defmacro defarmsfpr (name val) 120 `(defconstant ,name (define-arm-register ',name ',val))) 121 122 (defarmsfpr s0 32) 123 (defarmsfpr s1 33) 124 (defarmsfpr s2 34) 125 (defarmsfpr s3 35) 126 (defarmsfpr s4 36) 127 (defarmsfpr s5 37) 128 (defarmsfpr s6 38) 129 (defarmsfpr s7 39) 130 (defarmsfpr s8 40) 131 (defarmsfpr s9 41) 132 (defarmsfpr s10 42) 133 (defarmsfpr s11 43) 134 (defarmsfpr s12 44) 135 (defarmsfpr s13 45) 136 (defarmsfpr s14 46) 137 (defarmsfpr s15 47) 138 (defarmsfpr s16 48) 139 (defarmsfpr s17 49) 140 (defarmsfpr s18 50) 141 (defarmsfpr s19 51) 142 (defarmsfpr s20 52) 143 (defarmsfpr s21 53) 144 (defarmsfpr s22 54) 145 (defarmsfpr s23 55) 146 (defarmsfpr s24 56) 147 (defarmsfpr s25 57) 148 (defarmsfpr s26 58) 149 (defarmsfpr s27 59) 150 (defarmsfpr s28 60) 151 (defarmsfpr s29 61) 152 (defarmsfpr s30 62) 153 (defarmsfpr s31 63) 154 155 ;;; The first 16 double-float registers overlap pairs of single-float 156 ;;; registers (d0 overlaps s0-s1, d15 overlaps s30-s31, etc.) 157 158 (defmacro defarmdfpr (name val) 159 `(defconstant ,name (define-arm-register ',name ',val))) 160 161 (defarmdfpr d0 64) 162 (defarmdfpr d1 65) 163 (defarmdfpr d2 66) 164 (defarmdfpr d3 67) 165 (defarmdfpr d4 68) 166 (defarmdfpr d5 69) 167 (defarmdfpr d6 70) 168 (defarmdfpr d7 71) 169 (defarmdfpr d8 72) 170 (defarmdfpr d9 73) 171 (defarmdfpr d10 74) 172 (defarmdfpr d11 75) 173 (defarmdfpr d12 76) 174 (defarmdfpr d13 77) 175 (defarmdfpr d14 78) 176 (defarmdfpr d15 79) 109 177 110 178 … … 218 286 (eval-when (:compile-toplevel :load-toplevel :execute) 219 287 (defparameter *arm-subprims-shift* 8) 220 (defparameter *arm-subprims-base* (ash 412) )288 (defparameter *arm-subprims-base* (ash 9 12) ) 221 289 ) 222 290 (defvar *arm-subprims*) … … 229 297 (ccl::make-subprimitive-info :name (string name) 230 298 :offset (prog1 origin 299 (when (= origin #x10000) 300 (setq step (ash 1 10))) 231 301 (incf origin step))))) 232 302 (macrolet ((defarmsubprim (name) … … 449 519 (defconstant target-most-negative-fixnum (ash -1 (1- (- nbits-in-word nfixnumtagbits)))) 450 520 (defconstant target-most-positive-fixnum (1- (ash 1 (1- (- nbits-in-word nfixnumtagbits))))) 521 (defconstant fixnumone (ash 1 fixnumshift)) 522 451 523 452 524 … … 1313 1385 al) 1314 1386 1315 (defconstant arm-cond-eq 0)1316 (def1317 1387 1318 1388 (provide "ARM-ARCH") -
branches/arm/compiler/ARM/arm-asm.lisp
r13736 r13741 94 94 (eval-when (:compile-toplevel :load-toplevel :execute) 95 95 96 (ccl::defenum (:prefix "ARM-OPERAND-TYPE-") 97 rd ; destination register in bits 12:15 98 rn ; unshifted source/base reg in 16:19 99 shifter ; composite operand for ALU ops 100 mem12 ; 12-bit address for LDR/STR/LDRB/STB 101 reglist 102 rnw ; rn, with optional writeback. 103 uuoA ; GPR in UUO bits 8:11 104 uuo-unary ; constant in UUO bits 12:15 105 uuoB ; GPR in UUO bits 12:15 106 rm 107 b 108 subprim 109 mem8 110 ) 111 112 (defparameter *arm-operand-type-names* 113 `((:rd . ,arm-operand-type-rd) 114 (:rn . ,arm-operand-type-rn) 115 (:shifter . ,arm-operand-type-shifter) 116 (:mem12 . ,arm-operand-type-mem12) 117 (:reglist . ,arm-operand-type-reglist) 118 (:rnw . ,arm-operand-type-rnw) 119 (:uuoA . ,arm-operand-type-uuoA) 120 (:uuo-unary . ,arm-operand-type-uuo-unary) 121 (:uuoB . ,arm-operand-type-uuoB) 122 (:rm . ,arm-operand-type-rm) 123 (:b . ,arm-operand-type-b) 124 (:subprim . ,arm-operand-type-subprim) 125 (:mem8 . ,arm-operand-type-mem8) 96 (defparameter *arm-operand-types* 97 #(:rd ; destination register in bits 12:15 98 :rn ; unshifted source/base reg in 16:19 99 :shifter ; composite operand for ALU ops 100 :mem12 ; 12-bit address for LDR/STR/LDRB/STB 101 :reglist 102 :rnw ; rn, with optional writeback. 103 :uuoA ; GPR in UUO bits 8:11 104 :uuo-unary ; constant in UUO bits 12:15 105 :uuoB ; GPR in UUO bits 12:15 106 :rm 107 :b 108 :subprim 109 :mem8 110 :dd 111 :dm 112 :sd 113 :sm 114 :dn 115 :sn 116 :rde 117 :rs 126 118 )) 127 119 128 129 130 131 (defun encode-arm-operand-type (name) 132 (or (cdr (assoc name *arm-operand-type-names* :test #'eq)) 120 (defun %encode-arm-operand-type (name) 121 (or (position name *arm-operand-types* :test #'eq) 133 122 (error "Unknown ARM operand type name ~s." name))) 123 124 (defmacro encode-arm-operand-type (name) 125 (%encode-arm-operand-type name)) 134 126 135 127 (ccl::defenum (:prefix "ARM-INSTRUCTION-FLAG-") … … 172 164 173 165 (defmacro define-arm-instruction (name operand-type-names value mask-list flag-names) 174 `(%define-arm-instruction ,(string-downcase name) ,value ',mask-list ,(%encode-arm-instruction-flag flag-names) ',(mapcar #' encode-arm-operand-type operand-type-names) ))166 `(%define-arm-instruction ,(string-downcase name) ,value ',mask-list ,(%encode-arm-instruction-flag flag-names) ',(mapcar #'%encode-arm-operand-type operand-type-names) )) 175 167 176 168 (defparameter *arm-instruction-table* … … 185 177 (:prefer-separate-cond)) 186 178 (define-arm-instruction uuo-error-wrong-nargs () 187 #x07f00 0f1179 #x07f001f8 188 180 #x0fffffff 189 181 (:prefer-separate-cond)) 190 182 (define-arm-instruction uuo-gc-trap () 191 #x07f00 1f2183 #x07f002f0 192 184 #x0fffffff 193 185 (:prefer-separate-cond)) 194 186 (define-arm-instruction uuo-debug-trap () 195 #x07f002f 3187 #x07f002f0 196 188 #x0fffffff 197 189 (:prefer-separate-cond)) 198 190 (define-arm-instruction uuo-interrupt-now () 199 #x07f003f 4191 #x07f003f0 200 192 #x0fffffff 201 193 (:prefer-separate-cond)) 202 194 (define-arm-instruction uuo-suspend-now () 203 #x07f004f0 5195 #x07f004f0 204 196 #x0fffffff 205 197 (:prefer-separate-cond)) … … 232 224 ;;; Unary UUOs 233 225 (define-arm-instruction uuo-error-unbound (:uuoA) 234 #x07f000f 1226 #x07f000f9 235 227 #x0ffff0ff 236 228 (:prefer-separate-cond)) 237 229 (define-arm-instruction uuo-cerror-unbound (:uuoA) 238 #x07f010f 1230 #x07f010f9 239 231 #x0ffff0ff 240 232 (:prefer-separate-cond)) 241 233 (define-arm-instruction uuo-error-not-callable (:uuoA) 242 #x07f020f 1234 #x07f020f9 243 235 #x0ffff0ff 244 236 (:prefer-separate-cond)) … … 248 240 (:prefer-separate-cond)) 249 241 (define-arm-instruction uuo-error-no-throw-tag (:uuoA) 250 #x07f040f 1242 #x07f040f9 251 243 #x0ffff0ff 252 244 (:prefer-separate-cond)) 253 245 (define-arm-instruction uuo-error-udf-call (:uuoA) 246 #x07f050f9 247 #x0ffff0ff 248 (:prefer-separate-cond)) 249 (define-arm-instruction uuo-error-udf (:uuoA) 250 #x07f060f9 251 #x0ffff0ff 252 (:prefer-separate-cond)) 253 254 254 ;;; Binary UUOs 255 255 (define-arm-instruction uuo-error-vector-bounds (:uuoA :uuoB) … … 261 261 #x0fff00ff 262 262 (:prefer-separate-cond)) 263 263 (define-arm-instruction uuo-error-integer-divide-by-zero (:uuoA :uuoB) 264 #x07f200ff 265 #x0fff00ff 266 (:prefer-separate-cond)) 267 (define-arm-instruction uuo-error-slot-unbound (:uuoA :uuoB) 268 #x07f300ff 269 #x0fff00ff 270 (:prefer-separate-cond)) 264 271 265 272 (define-arm-instruction and (:rd :rn :shifter) … … 484 491 #x0e3000f0 485 492 ()) 486 493 (define-arm-instruction ldrd (:rde :mem8) 494 #x000000d0 495 #x0e3000f0 496 ()) 497 (define-arm-instruction strd (:rde :mem8) 498 #x000000f0 499 #x0e3000f0 500 ()) 501 502 (define-arm-instruction mul (:rd :rm :rs) 503 #x00000090 504 #x0ff000f0 505 ()) 506 (define-arm-instruction muls (:rd :rm :rs) 507 #x00100090 508 #x0ff000f0 509 ()) 510 487 511 (define-arm-instruction stm (:rnw :reglist) 488 512 #x08800000 … … 545 569 #x012fff30 546 570 #x0ffffff0 571 ()) 572 573 ;;; VFP instructions 574 (define-arm-instruction fabsd (:dd :dm) 575 #x0eb00bc0 576 #x0ff00ff0 577 ()) 578 (define-arm-instruction fabss (:sd :sm) 579 #x0eb00ac0 580 #x0fb00fb0 581 ()) 582 (define-arm-instruction faddd (:dd :dn :dm) 583 #x0e300b00 584 #x0ff00ff0 585 ()) 586 (define-arm-instruction fadds (:sd :sn :sm) 587 #x0e300a00 588 #x0f300f50 589 ()) 590 (define-arm-instruction fmsr (:sn :rd) 591 #x0e000a10 592 #x0ff00f90 593 ()) 594 (define-arm-instruction fmrs (:rd :sn) 595 #x0e100a10 596 #x0ff00f90 597 ()) 598 (define-arm-instruction fmrrd (:rd :rn :dm) 599 #x0e500b10 600 #x0ff00ff0 601 ()) 602 (define-arm-instruction fmdrr (:dm :rd :rn) 603 #x0e400b10 604 #x0ff00ff0 605 ()) 606 (define-arm-instruction fsitod (:dd :sm) 607 #x0eb80bc0 608 #x0fff0fc0 609 ()) 610 (define-arm-instruction fsitos (:sd :sm) 611 #x0eb80ac0 612 #x0fff0fc0 613 ()) 614 (define-arm-instruction fcmped (:dd :dm) 615 #x0eb40bc0 616 #x0fff0fc0 617 ()) 618 (define-arm-instruction fcmpes (:dd :dm) 619 #x0eb40ac0 620 #x0fff0fc0 621 ()) 622 (define-arm-instruction fmstat () 623 #x0ef1fa10 624 #x0fffffff 625 ()) 626 (define-arm-instruction fsubd (:dd :dn :dm) 627 #x0e300b40 628 #x0ff00fc0 629 ()) 630 (define-arm-instruction fsubs (:sd :sn :sm) 631 #x0e300a40 632 #x0ff00fc0 633 ()) 634 (define-arm-instruction fmuld (:dd :dn :dm) 635 #x0e200b00 636 #x0ff00ff0 637 ()) 638 (define-arm-instruction fmuls (:sd :sn :sm) 639 #x0e200a00 640 #x0ff00ff0 641 ()) 642 (define-arm-instruction fdivd (:dd :dn :dm) 643 #x0e800b00 644 #x0ff00ff0 645 ()) 646 (define-arm-instruction fdivs (:sd :sn :sm) 647 #x0e800a00 648 #x0ff00ff0 649 ()) 650 (define-arm-instruction fcpyd (:dd :dm) 651 #x0eb00b40 652 #x0fb00ff0 653 ()) 654 (define-arm-instruction fcpyd (:sd :sm) 655 #x0eb00b40 656 #x0fb00fc0 657 ()) 658 (define-arm-instruction fcvtsd (:sd :dm) 659 #x0eb70bc0 660 #x0fbf0fc0 547 661 ()) 548 662 )) … … 667 781 (or (get-arm-gpr form) 668 782 (error "Expected an ARM general-purpose register, got ~s" form))) 783 784 (defun need-arm-sfpr (form) 785 (or (get-arm-sfpr form) 786 (error "Expected an ARM single FP register, got ~s" form))) 787 788 (defun need-arm-dfpr (form) 789 (or (get-arm-sfpr form) 790 (error "Expected an ARM double FP register, got ~s" form))) 669 791 670 792 (defun encode-arm-shift-type (op) … … 943 1065 (set-addressing-mode instruction mode constant-index)))) 944 1066 945 946 1067 (defun parse-dd-operand (form instruction) 1068 (set-field-value instruction (byte 4 12) (need-arm-dfpr form))) 1069 1070 (defun parse-dm-operand (form instruction) 1071 (set-field-value instruction (byte 4 0) (need-arm-dfpr form))) 1072 1073 (defun parse-sd-operand (form instruction) 1074 (let* ((val (need-arm-sfpr form))) 1075 (set-field-value instruction (byte 4 12) (ash val -1)) 1076 (set-field-value instruction (byte 1 22) (logand val 1)))) 1077 1078 (defun parse-sm-operand (form instruction) 1079 (let* ((val (need-arm-sfpr form))) 1080 (set-field-value instruction (byte 4 0) (ash val -1)) 1081 (set-field-value instruction (byte 1 5) (logand val 1)))) 1082 1083 (defun parse-dn-operand (form instruction) 1084 (set-field-value instruction (byte 4 16) (need-arm-dfpr form))) 947 1085 948 949 1086 (defun parse-sn-operand (form instruction) 1087 (let* ((val (need-arm-sfpr form))) 1088 (set-field-value instruction (byte 4 16) (ash val -1)) 1089 (set-field-value instruction (byte 1 7) (logand val 1)))) 1090 1091 (defun parse-rde-operand (form instruction) 1092 (let* ((val (need-arm-gpr form))) 1093 (when (oddp val) 1094 (error "Register must be even-numbered: ~s." form)) 1095 (set-field-value instruction (byte 4 12) val))) 1096 1097 (defun parse-rs-operand (form instruction) 1098 (set-field-value instruction (byte 4 8) (need-arm-gpr form))) 1099 950 1100 (defparameter *arm-operand-parsers* 951 1101 #(parse-rd-operand … … 962 1112 parse-subprim-operand 963 1113 parse-m8-operand 1114 parse-dd-operand 1115 parse-dm-operand 1116 parse-sd-operand 1117 parse-sm-operand 1118 parse-dn-operand 1119 parse-sn-operand 1120 parse-rde-operand 1121 parse-rs-operand 964 1122 )) 965 1123 … … 1102 1260 (ccl::append-dll-node w1 primary ) 1103 1261 (let* ((n (set-element-addresses 0 primary))) 1104 (setf (lap-instruction-opcode w1) n)1262 (setf (lap-instruction-opcode w1) (ash n (- arm::word-shift))) 1105 1263 (set-element-addresses n constant-pool))) 1106 1264 ;; Now fix up label references. Recall that the PC value at some … … 1187 1345 1188 1346 1347 (eval-when (:compile-toplevel :load-toplevel :execute) 1189 1348 (defparameter *vinsn-field-types* 1190 1349 #(:cond … … 1206 1365 :application 1207 1366 :local-label 1208 )) 1367 :dd 1368 :dm 1369 :sd 1370 :sm 1371 :dn 1372 :sn 1373 ))) 1209 1374 1210 1375 (defmacro encode-vinsn-field-type (name) … … 1226 1391 vinsn-parse-subprim-operand 1227 1392 vinsn-parse-m8-operand 1393 vinsn-parse-dd-operand 1394 vinsn-parse-dm-operand 1395 vinsn-parse-sd-operand 1396 vinsn-parse-sm-operand 1397 vinsn-parse-dn-operand 1398 vinsn-parse-sn-operand 1399 vinsn-parse-rde-operand 1400 vinsn-parse-rs-operand 1228 1401 )) 1229 1402 … … 1236 1409 (set-avi-opcode-field avi bytespec (need-arm-gpr form)))))) 1237 1410 1411 (defun vinsn-arg-or-dfpr (avi form vinsn-params encoded-type bytespec) 1412 (let* ((p (position form vinsn-params))) 1413 (cond (p 1414 (add-avi-operand avi encoded-type p) 1415 nil) 1416 (t 1417 (set-avi-opcode-field avi bytespec (need-arm-dfpr form)))))) 1418 1419 (defun vinsn-arg-or-sfpr (avi form vinsn-params encoded-type top4 low1) 1420 (let* ((p (position form vinsn-params))) 1421 (cond (p 1422 (add-avi-operand avi encoded-type p) 1423 nil) 1424 (t 1425 (let* ((val (need-arm-sfpr form))) 1426 (set-avi-opcode-field avi top4 (ash val -1)) 1427 (set-avi-opcode-field avi low1 (logand val 1))))))) 1428 1429 (defun simplify-arm-vinsn-application (form params) 1430 (labels ((simplify-operand (op) 1431 (if (atom op) 1432 (if (typep form 'fixnum) 1433 op 1434 (if (constantp op) 1435 (eval op) 1436 (let* ((p (position op params))) 1437 (if p 1438 (list p) 1439 (error "Unknown operand: ~s" op))))) 1440 (if (eq (car op) :apply) 1441 `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op))))))) 1442 `(,(cadr form) ,@(mapcar #'simplify-operand (cddr form))))) 1443 1238 1444 (defun vinsn-arg-or-constant (avi form vinsn-params encoded-type bytespec) 1239 1445 (let* ((p (position form vinsn-params))) … … 1241 1447 (add-avi-operand avi encoded-type p) 1242 1448 nil) 1449 ((typep form 'keyword) 1450 (add-avi-operand avi encoded-type form) 1451 nil) 1243 1452 ((and (consp form) (eq (car form) :apply)) 1244 (add-avi-operand avi encoded-type (simplify-a pplication form vinsn-params))1453 (add-avi-operand avi encoded-type (simplify-arm-vinsn-application form vinsn-params)) 1245 1454 nil) 1246 1455 (t … … 1300 1509 1301 1510 (defun vinsn-parse-m12-operand (avi value vinsn-params) 1511 (when (typep value 'keyword) 1512 (setq value `(:@ arm::pc (:$ ,value)))) 1302 1513 (destructuring-bind (op rn index) value ; no (:@ reg) sugar 1303 1514 (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16)) … … 1350 1561 (destructuring-bind (marker reg) value 1351 1562 (if (eq marker :!) 1352 (set-avi-opcode-field avi (byte 1 21) 1) )1353 (error "Unrecognized writeback indicator in ~s." value) 1563 (set-avi-opcode-field avi (byte 1 21) 1) 1564 (error "Unrecognized writeback indicator in ~s." value)) 1354 1565 reg)))) 1355 1566 (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16)))) … … 1378 1589 ((typep value 'keyword) 1379 1590 (add-avi-operand avi (encode-vinsn-field-type :local-label) value)) 1591 ((arm-subprimitive-address value) 1592 (add-avi-operand avi (encode-vinsn-field-type :subprim) value)) 1380 1593 (t 1381 1594 (error "Unknown branch target: ~s." value))))) … … 1434 1647 (set-opcode-value-from-addressing-mode (avi-opcode avi) mode constant-index)))))) 1435 1648 1436 1437 1438 1439 1649 (defun vinsn-parse-dd-operand (avi value vinsn-params) 1650 (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dd) (byte 4 12))) 1651 1652 (defun vinsn-parse-dm-operand (avi value vinsn-params) 1653 (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dm) (byte 4 0))) 1654 1655 (defun vinsn-parse-sd-operand (avi value vinsn-params) 1656 (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sd) (byte 4 12) (byte 1 22))) 1657 1658 (defun vinsn-parse-sm-operand (avi value vinsn-params) 1659 (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sm) (byte 4 0) (byte 1 5))) 1660 1661 (defun vinsn-parse-dn-operand (avi value vinsn-params) 1662 (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dn) (byte 4 16))) 1663 1664 (defun vinsn-parse-sn-operand (avi value vinsn-params) 1665 (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sn) (byte 4 16) (byte 1 7))) 1666 1667 (defun vinsn-parse-rde-operand (avi value vinsn-params) 1668 (let* ((val (get-arm-gpr value))) 1669 (when (and val (oddp val)) 1670 (error "Register ~s must be even-numbered." value))) 1671 (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rd) (byte 4 12))) 1672 1673 (defun vinsn-parse-rs-operand (avi value vinsn-params) 1674 (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rs) (byte 4 8))) 1675 1440 1676 (defun vinsn-simplify-instruction (form vinsn-params) 1441 1677 (destructuring-bind (name . opvals) form 1442 (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name) 1443 (unless template 1444 (error "Unknown ARM instruction - ~s" form)) 1445 (let* ((cond-indicator (and (consp (car opvals)) 1446 (keywordize (caar opvals)))) 1447 (avi (make-arm-vinsn-instruction (arm-instruction-template-val template)))) 1448 (when (or (eq cond-indicator :?) 1449 (eq cond-indicator :~)) 1450 (let* ((condform (pop opvals))) 1451 (destructuring-bind (cond-name) (cdr condform) 1452 (let* ((p (position cond-name vinsn-params))) 1453 (if p 1454 (if explicit-cond 1455 (error "Can't use ~s with explicit condition name." condform) 1456 (progn 1457 (add-avi-operand avi (if (eq cond-indicator :?) 1458 (encode-vinsn-field-type :cond) 1459 (encode-vinsn-field-type :negated-cond)) 1460 p) 1461 (setq cond nil))) 1462 (let* ((c (need-arm-condition-name cond-name))) 1463 (when (eq cond-indicator :~) 1464 (if (< c 14) 1465 (setq c (logxor c 1)) 1466 (error "Invalid explicit condition ~s." condform))) 1467 (if (and explicit-cond (not (eql c cond))) 1468 (error "Can't use explicit condition and :? : ~s" condform) 1469 (setq cond c)))))))) 1470 (let* ((optypes (arm-instruction-template-operand-types template)) 1471 (n (length optypes))) 1472 (unless (= n (length opvals)) 1473 (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form)) 1474 (dotimes (i n) 1475 (let* ((optype (pop optypes)) 1476 (opval (pop opvals))) 1477 (funcall (svref *arm-vinsn-operand-parsers* optype) 1478 avi opval vinsn-params))) 1479 (when cond 1480 (set-avi-opcode-field avi (byte 4 28) cond)) 1481 (avi-head avi)))))) 1678 (case name 1679 ((:code :data) form) 1680 (:word (destructuring-bind (val) opvals 1681 (let* ((p (position val vinsn-params))) 1682 (list name (if p (list p) (eval val)))))) 1683 (t 1684 (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name) 1685 (unless template 1686 (error "Unknown ARM instruction - ~s" form)) 1687 (let* ((cond-indicator (and (consp (car opvals)) 1688 (keywordize (caar opvals)))) 1689 (avi (make-arm-vinsn-instruction (arm-instruction-template-val template)))) 1690 (when (or (eq cond-indicator :?) 1691 (eq cond-indicator :~)) 1692 (let* ((condform (pop opvals))) 1693 (destructuring-bind (cond-name) (cdr condform) 1694 (let* ((p (position cond-name vinsn-params))) 1695 (if p 1696 (if explicit-cond 1697 (error "Can't use ~s with explicit condition name." condform) 1698 (progn 1699 (add-avi-operand avi (if (eq cond-indicator :?) 1700 (encode-vinsn-field-type :cond) 1701 (encode-vinsn-field-type :negated-cond)) 1702 p) 1703 (setq cond nil))) 1704 (let* ((c (need-arm-condition-name cond-name))) 1705 (when (eq cond-indicator :~) 1706 (if (< c 14) 1707 (setq c (logxor c 1)) 1708 (error "Invalid explicit condition ~s." condform))) 1709 (if (and explicit-cond (not (eql c cond))) 1710 (error "Can't use explicit condition and :? : ~s" condform) 1711 (setq cond c)))))))) 1712 (let* ((optypes (arm-instruction-template-operand-types template)) 1713 (n (length optypes))) 1714 (unless (= n (length opvals)) 1715 (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form)) 1716 (dotimes (i n) 1717 (let* ((optype (pop optypes)) 1718 (opval (pop opvals))) 1719 (funcall (svref *arm-vinsn-operand-parsers* optype) 1720 avi opval vinsn-params))) 1721 (when cond 1722 (set-avi-opcode-field avi (byte 4 28) cond)) 1723 (avi-head avi)))))))) 1482 1724 1483 1725 1726 (defparameter *arm-vinsn-insert-functions* 1727 #(vinsn-insert-rd-operand 1728 vinsn-insert-rn-operand 1729 vinsn-insert-shifter-operand 1730 vinsn-insert-m12-operand 1731 vinsn-insert-reglist-operand 1732 vinsn-insert-rnw-operand 1733 vinsn-insert-uuoa-operand 1734 vinsn-insert-uuo-unary-operand 1735 vinsn-insert-uuob-operand 1736 vinsn-insert-rm-operand 1737 vinsn-insert-b-operand 1738 vinsn-insert-subprim-operand 1739 vinsn-insert-m8-operand 1740 vinsn-insert-dd-operand 1741 vinsn-insert-dm-operand 1742 vinsn-insert-sd-operand 1743 vinsn-insert-sm-operand 1744 vinsn-insert-dn-operand 1745 vinsn-insert-sn-operand 1746 vinsn-insert-rde-operand 1747 vinsn-insert-rs-operand 1748 )) 1484 1749 1485 1750 (provide "ARM-ASM") -
branches/arm/compiler/ARM/arm-backend.lisp
r13715 r13741 32 32 ;;; evaluable at macroexpansion time. 33 33 (defun %define-arm-vinsn (backend vinsn-name results args temps body) 34 (let* ((opcode-vector (backend-lap-opcodes backend)) 35 (opcode-lookup (backend-lookup-opcode backend)) 36 (opcode-expander (backend-lookup-macro backend)) 37 (backend-name (backend-name backend)) 38 (arch-name (backend-target-arch-name backend)) 34 (let* ((arch-name (backend-target-arch-name backend)) 39 35 (template-hash (backend-p2-template-hash-name backend)) 40 36 (name-list ()) … … 98 94 (dolist (name non-hybrid-results) 99 95 (add-spec-name name))) 100 (break)101 #+notyet102 96 (let* ((k -1)) 103 97 (declare (fixnum k)) … … 169 163 (if (keywordp opname) 170 164 form 171 (let* ((name (string opname)) 172 (opnum (funcall opcode-lookup name))) 173 (if (and (not opnum) opcode-expander) 174 (let* ((expander (funcall opcode-expander name))) 175 (if expander 176 (simplify-form (funcall expander form nil)) 177 (error "Unknown ~A instruction in ~s" backend-name form))) 178 (let* ((opcode (if (< -1 opnum (length opcode-vector)) 179 (svref opcode-vector opnum) 180 (error "~& Invalid ~A opcode: ~s" backend-name name))) 181 (opvals (mapcar #'simplify-operand opvals))) 182 (setf (assq opnum opcode-alist) name) 183 (let* ((operands (opcode-vinsn-operands opcode)) 184 (nmin (opcode-min-vinsn-args opcode)) 185 (nmax (opcode-max-vinsn-args opcode)) 186 (nhave (length opvals))) 187 (declare (fixnum nmin nmax nhave)) 188 (if (= nhave nmax) 189 `(,opnum ,@opvals) 190 (if (> nhave nmax) 191 (error "Too many operands in ~s (~a accepts at most ~d)" 192 (cdr w) name nmax) 193 (if (= nhave nmin) 194 (let* ((newops ())) 195 (dolist (op operands `(,opnum ,@(nreverse newops))) 196 (let* ((flags (operand-flags op))) 197 (unless (logbitp operand-fake flags) 198 (push (if (logbitp operand-optional flags) 199 0 200 (pop opvals)) 201 newops))))) 202 (error "Too few operands in ~s : (~a requires at least ~d)" 203 (cdr w) name nmin)))))))))))))) 165 (arm::vinsn-simplify-instruction form name-list))))))) 204 166 (let* ((template (make-vinsn-template 205 167 :name vinsn-name -
branches/arm/compiler/ARM/arm-disassemble.lisp
r13735 r13741 28 28 (defun arm-gpr-name (regno) 29 29 `(:gpr ,regno)) 30 31 (defun arm-fprd-name (regno) 32 `(:double ,regno)) 33 34 (defun arm-fprs-name (regno) 35 `(:single ,regno)) 30 36 31 37 … … 210 216 (if u :@+ :@-)) ,rn ,rm))))))) 211 217 218 (defun extract-arm-dd-operand (opcodes i) 219 (let* ((opcode (adi-opcode (svref opcodes i)))) 220 (arm-fprd-name (ldb (byte 4 12) opcode)))) 221 222 (defun extract-arm-dm-operand (opcodes i) 223 (let* ((opcode (adi-opcode (svref opcodes i)))) 224 (arm-fprd-name (ldb (byte 4 0) opcode)))) 225 226 (defun extract-arm-sd-operand (opcodes i) 227 (let* ((opcode (adi-opcode (svref opcodes i)))) 228 (arm-fprs-name (logior (ash (ldb (byte 4 12) opcode) 1) 229 (ldb (byte 1 22) opcode))))) 230 231 (defun extract-arm-sm-operand (opcodes i) 232 (let* ((opcode (adi-opcode (svref opcodes i)))) 233 (arm-fprs-name (logior (ash (ldb (byte 4 0) opcode) 1) 234 (ldb (byte 1 5) opcode))))) 235 236 (defun extract-arm-dn-operand (opcodes i) 237 (let* ((opcode (adi-opcode (svref opcodes i)))) 238 (arm-fprd-name (ldb (byte 4 16) opcode)))) 239 240 (defun extract-arm-sn-operand (opcodes i) 241 (let* ((opcode (adi-opcode (svref opcodes i)))) 242 (arm-fprd-name (logior (ash (ldb (byte 4 16) opcode) 1) 243 (ldb (byte 1 7) opcode))))) 244 245 212 246 (defparameter *arm-operand-extract-functions* 213 247 #(extract-arm-rd-operand … … 224 258 extract-arm-subprim-operand 225 259 extract-arm-m8-operand 260 extract-arm-dd-operand 261 extract-arm-dm-operand 262 extract-arm-sd-operand 263 extract-arm-sm-operand 264 extract-arm-dn-operand 265 extract-arm-sn-operand 226 266 )) 227 267 … … 319 359 (:? (format stream "(:? ~a)" (cadr operand))) 320 360 (:gpr (format stream "~a" (svref *arm-gpr-names* (cadr operand)))) 361 (:single (format stream "s~d" (cadr operand))) 362 (:double (format stream "d~d" (cadr operand))) 321 363 (:reglist (format stream "~a" 322 364 (mapcar (lambda (r) -
branches/arm/compiler/ARM/arm-lap.lisp
r13715 r13741 127 127 (:data 128 128 (setq current (svref sections 1))) 129 (: text129 (:code 130 130 (setq current (svref sections 0))) 131 131 (:section 132 132 (setq current (svref sections 133 133 (ecase arg 134 (: text0)134 (:code 0) 135 135 (:data 1))))) 136 136 (:word -
branches/arm/compiler/ARM/arm-vinsns.lisp
r13713 r13741 48 48 ) 49 49 ()) 50 (mov dest (:lsr idx 1))50 (mov dest (:lsr idx (:$ 1))) 51 51 (add dest dest (:$ arm::misc-data-offset))) 52 52 … … 55 55 ) 56 56 ()) 57 (mov dest (:lsr idx 2))57 (mov dest (:lsr idx (:$ 2))) 58 58 (add dest dest (:$ arm::misc-data-offset))) 59 59 … … 65 65 (add dest dest (:$ arm::misc-dfloat-offset))) 66 66 67 #+notyet 67 68 (define-arm-vinsn scale-1bit-misc-index (((word-index :u32) 68 69 (bitnum :u8)) ; (unsigned-byte 5) … … 135 136 ((v :lisp) 136 137 (scaled-idx :u32)) 137 ()) 138 (lfsx dest v scaled-idx)) 138 ((temp :u32))) 139 (ldr temp (:@ v scaled-idx)) 140 (fmsr dest temp)) 139 141 140 142 (define-arm-vinsn misc-ref-c-single-float (((dest :single-float)) 141 143 ((v :lisp) 142 144 (idx :u32const)) 143 ()) 144 (lfs dest (:apply + arm::misc-data-offset (:apply ash idx 2)) v)) 145 ((temp :u32))) 146 (ldr temp (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))) 147 (fmsr dest temp)) 145 148 146 149 (define-arm-vinsn misc-ref-double-float (((dest :double-float)) 147 150 ((v :lisp) 148 151 (scaled-idx :u32)) 149 ()) 150 (lfdx dest v scaled-idx)) 152 ((low (:u32 #.arm::imm0)) 153 (high (:u32 #.arm::imm1)))) 154 (ldrd low (:@ v scaled-idx)) 155 (fmdrr dest low high)) 151 156 152 157 … … 154 159 ((v :lisp) 155 160 (idx :u32const)) 156 ()) 157 (lfd dest (:apply + arm::misc-dfloat-offset (:apply ash idx 3)) v)) 161 ((low (:u32 #.arm::imm0)) 162 (high (:u32 #.arm::imm1)))) 163 (ldrd low (:@ v (:$ idx))) 164 (fmdrr dest low high)) 158 165 159 166 (define-arm-vinsn misc-set-c-double-float (((val :double-float)) 160 167 ((v :lisp) 161 (idx :u32const))) 162 (stfd val (:apply + arm::misc-dfloat-offset (:apply ash idx 3)) v)) 168 (idx :u32const)) 169 ((low (:u32 #.arm::imm0)) 170 (high (:u32 #.arm::imm1)))) 171 (fmrrd low high val) 172 (strd low (:@ v (:$ (:apply + arm::misc-dfloat-offset (:apply ash idx 3)))))) 163 173 164 174 (define-arm-vinsn misc-set-double-float (() 165 175 ((val :double-float) 166 176 (v :lisp) 167 (scaled-idx :u32))) 168 (stfdx val v scaled-idx)) 169 170 (define-arm-vinsn misc-set-c-single-float (((val :single-float)) 171 ((v :lisp) 172 (idx :u32const))) 173 (stfs val (:apply + arm::misc-data-offset (:apply ash idx 2)) v)) 177 (scaled-idx :u32)) 178 ((low (:u32 #.arm::imm0)) 179 (high (:u32 #.arm::imm1)))) 180 (fmrrd low high val) 181 (strd low (:@ v scaled-idx))) 182 183 (define-arm-vinsn misc-set-c-single-float (() 184 ((val :single-float) 185 (v :lisp) 186 (idx :u32const)) 187 ((temp :u32))) 188 (fmrs temp val) 189 (str temp (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2)))))) 174 190 175 191 … … 178 194 ((val :single-float) 179 195 (v :lisp) 180 (scaled-idx :u32))) 181 (stfsx val v scaled-idx)) 196 (scaled-idx :u32)) 197 ((temp :u32))) 198 (fmrs temp val) 199 (str temp (:@ v scaled-idx))) 182 200 183 201 … … 198 216 (idx :u32const)) 199 217 ()) 200 (strh val (:+@ v (: apply + arm::misc-data-offset (:apply ash idx 1)))))218 (strh val (:+@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1)))))) 201 219 202 220 (define-arm-vinsn misc-set-u16 (((val :u16)) … … 209 227 (scaled-idx :u32)) 210 228 ()) 211 (l hax dest v scaled-idx))229 (ldrsh dest (:@ v scaled-idx))) 212 230 213 231 (define-arm-vinsn misc-ref-c-s16 (((dest :s16)) … … 215 233 (idx :u32const)) 216 234 ()) 217 (l ha dest (:apply + arm::misc-data-offset (:apply ash idx 1)) v))235 (ldrsh dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1)))))) 218 236 219 237 … … 222 240 (idx :u32const)) 223 241 ()) 224 (st h val (:apply + arm::misc-data-offset (:apply ash idx 1)) v))242 (strh val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1)))))) 225 243 226 244 (define-arm-vinsn misc-set-s16 (((val :s16)) 227 245 ((v :lisp) 228 246 (scaled-idx :s32))) 229 (st hx val v scaled-idx))247 (strh val (:@ v scaled-idx))) 230 248 231 249 (define-arm-vinsn misc-ref-u8 (((dest :u8)) … … 233 251 (scaled-idx :u32)) 234 252 ()) 235 (l bzx dest v scaled-idx))253 (ldrb dest (:@ v scaled-idx))) 236 254 237 255 (define-arm-vinsn misc-ref-c-u8 (((dest :u8)) … … 239 257 (idx :u32const)) 240 258 ()) 241 (l bz dest (:apply + arm::misc-data-offset idx) v))259 (ldrb dest (:@ v (:$ (:apply + arm::misc-data-offset idx))))) 242 260 243 261 (define-arm-vinsn misc-set-c-u8 (((val :u8)) … … 245 263 (idx :u32const)) 246 264 ()) 247 (st b val (:apply + arm::misc-data-offset idx) v))265 (strb val (:@ v (:$ (:apply + arm::misc-data-offset idx))))) 248 266 249 267 (define-arm-vinsn misc-set-u8 (((val :u8)) … … 251 269 (scaled-idx :u32)) 252 270 ()) 253 (st bx val v scaled-idx))271 (strb val (:@ v scaled-idx))) 254 272 255 273 (define-arm-vinsn misc-ref-s8 (((dest :s8)) … … 257 275 (scaled-idx :u32)) 258 276 ()) 259 (lbzx dest v scaled-idx) 260 (extsb dest dest)) 277 (ldrsb dest (:@ v scaled-idx))) 261 278 262 279 (define-arm-vinsn misc-ref-c-s8 (((dest :s8)) … … 264 281 (idx :u32const)) 265 282 ()) 266 (lbz dest (:apply + arm::misc-data-offset idx) v) 267 (extsb dest dest)) 283 (ldrsb dest (:@ v (:$ (:apply + arm::misc-data-offset idx))))) 268 284 269 285 (define-arm-vinsn misc-set-c-s8 (((val :s8)) … … 271 287 (idx :u32const)) 272 288 ()) 273 (st b val (:apply + arm::misc-data-offset idx) v))289 (strb val (:@ v (:$ (:apply + arm::misc-data-offset idx))))) 274 290 275 291 (define-arm-vinsn misc-set-s8 (((val :s8)) … … 277 293 (scaled-idx :u32)) 278 294 ()) 279 (stbx val v scaled-idx)) 280 295 (strb val (:@ v scaled-idx))) 296 297 #+notyet 281 298 (define-arm-vinsn misc-ref-c-bit (((dest :u8)) 282 299 ((v :lisp) … … 286 303 (rlwinm dest dest (:apply 1+ (:apply logand idx #x1f)) 31 31)) 287 304 305 #+notyet 288 306 (define-arm-vinsn misc-ref-c-bit-fixnum (((dest :imm)) 289 307 ((v :lisp) … … 302 320 (scaled-idx :s32)) 303 321 ()) 304 (l wzx dest v scaled-idx))322 (ldr dest (:@ v scaled-idx))) 305 323 306 324 … … 311 329 (idx :s16const)) 312 330 ()) 313 (l wz dest (:apply + arm::misc-data-offset (:apply ash idx 2)) v))331 (ldr dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2)))))) 314 332 315 333 (define-arm-vinsn misc-set-node (() … … 317 335 (v :lisp) 318 336 (scaled-idx :u32))) 319 (st wx val v scaled-idx))337 (str val (:@ v scaled-idx))) 320 338 321 339 ;;; This should only be used for initialization (when the value being … … 326 344 (idx :s16const)) 327 345 ()) 328 (st w val (:apply + arm::misc-data-offset (:apply ash idx 2)) v))346 (str val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2)))))) 329 347 330 348 … … 332 350 ((v :lisp)) 333 351 ((temp :u32))) 334 (lwz temp arm::misc-header-offset v) 335 (rlwinm dest 336 temp 337 (- arm::nbits-in-word (- arm::num-subtag-bits arm::fixnumshift)) 338 (- arm::num-subtag-bits arm::fixnumshift) 339 (- arm::least-significant-bit arm::fixnumshift))) 352 (ldr temp (:@ v (:$ arm::misc-header-offset))) 353 (bic temp temp (:$ arm::subtag-mask)) 354 (mov dest (:lsr temp (:$ (- arm::num-subtag-bits arm::fixnum-shift))))) 340 355 341 356 (define-arm-vinsn check-misc-bound (() … … 343 358 (v :lisp)) 344 359 ((temp :u32))) 345 (lwz temp arm::misc-header-offset v) 346 (rlwinm temp 347 temp 348 (- arm::nbits-in-word (- arm::num-subtag-bits arm::fixnumshift)) 349 (- arm::num-subtag-bits arm::fixnumshift) 350 (- arm::least-significant-bit arm::fixnumshift)) 351 (twlge idx temp)) 360 (ldr temp (:@ v (:$ arm::misc-header-offset))) 361 (bic temp temp (:$ arm::subtag-mask)) 362 (cmp idx (:lsr temp (:$ (- arm::num-subtag-bits arm::fixnum-shift)))) 363 (uuo-error-vector-bounds (:? hs) idx v)) 352 364 353 365 (define-arm-vinsn 2d-unscaled-index (((dest :imm) … … 356 368 (i :imm) 357 369 (j :imm))) 358 (mul lwdim1 i dim1)370 (mul dim1 i dim1) 359 371 (add dest dim1 j)) 360 372 361 373 ;; dest <- (+ (* i dim1 dim2) (* j dim2) k) 374 362 375 (define-arm-vinsn 3d-unscaled-index (((dest :imm) 363 376 (dim1 :u32) … … 368 381 (j :imm) 369 382 (k :imm))) 370 (mul lwdim1 dim1 dim2)371 (mul lwdim2 j dim2)372 (mul lwdim1 i dim1)383 (mul dim1 dim1 dim2) 384 (mul dim2 j dim2) 385 (mul dim1 i dim1) 373 386 (add dim2 dim1 dim2) 374 387 (add dest dim2 k)) … … 377 390 (define-arm-vinsn 2d-dim1 (((dest :u32)) 378 391 ((header :lisp))) 379 (lwz dest (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))) header) 380 (srawi dest dest arm::fixnumshift)) 392 (ldr dest (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell)))))) 393 (mov dest (:asr dest (:$ arm::fixnumshift)))) 394 395 381 396 382 397 (define-arm-vinsn 3d-dims (((dim1 :u32) 383 398 (dim2 :u32)) 384 399 ((header :lisp))) 385 (l wz dim1 (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))) header)386 (l wz dim2 (+ arm::misc-data-offset (* 4 (+ 2 arm::arrayH.dim0-cell))) header)387 ( srawi dim1 dim1 arm::fixnumshift)388 ( srawi dim2 dim2 arm::fixnumshift))400 (ldr dim1 (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell)))))) 401 (ldr dim2 (:@ header (:$ (+ arm::misc-data-offset (* 4 (+ 2 arm::arrayH.dim0-cell)))))) 402 (mov dim1 (:asr dim1 (:$ arm::fixnumshift))) 403 (mov dim2 (:asr dim2 (:$ arm::fixnumshift)))) 389 404 390 405 ;; Return dim1 (unboxed) … … 393 408 (j :imm) 394 409 (header :lisp))) 395 (lwz dim (+ arm::misc-data-offset (* 4 arm::arrayH.dim0-cell)) header) 396 (twlge i dim) 397 (lwz dim (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))) header) 398 (twlge j dim) 399 (srawi dim dim arm::fixnumshift)) 410 (ldr dim (:@ header (:$ (+ arm::misc-data-offset (* 4 arm::arrayH.dim0-cell))))) 411 (cmp i dim) 412 (uuo-error-array-bounds (:? hs) i header) 413 (ldr dim (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell)))))) 414 (cmp j dim) 415 (uuo-error-array-bounds (:? hs) j header) 416 (mov dim (:asr dim (:$ arm::fixnumshift)))) 400 417 401 418 (define-arm-vinsn check-3d-bound (((dim1 :u32) … … 405 422 (k :imm) 406 423 (header :lisp))) 407 (lwz dim1 (+ arm::misc-data-offset (* 4 arm::arrayH.dim0-cell)) header) 408 (twlge i dim1) 409 (lwz dim1 (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))) header) 410 (twlge j dim1) 411 (lwz dim2 (+ arm::misc-data-offset (* 4 (+ 2 arm::arrayH.dim0-cell))) header) 412 (twlge k dim2) 413 (srawi dim1 dim1 arm::fixnumshift) 414 (srawi dim2 dim2 arm::fixnumshift)) 424 (ldr dim1 (:@ header (:$ (+ arm::misc-data-offset (* 4 arm::arrayH.dim0-cell))))) 425 (cmp i dim1) 426 (uuo-error-array-bounds (:? hs) i header) 427 (ldr dim1 (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell)))))) 428 (cmp j dim1) 429 (uuo-error-array-bounds (:? hs) i header) 430 (ldr dim2 (:@ header (:$ (+ arm::misc-data-offset (* 4 (+ 2 arm::arrayH.dim0-cell)))))) 431 (cmp k dim2) 432 (uuo-error-array-bounds (:? hs) i header) 433 (mov dim1 (:asr dim1 (:$ arm::fixnumshift))) 434 (mov dim2 (:asr dim2 (:$ arm::fixnumshift)))) 415 435 416 436 (define-arm-vinsn array-data-vector-ref (((dest :lisp)) 417 437 ((header :lisp))) 418 (l wz dest arm::arrayH.data-vector header))438 (ldr dest (:@ header (:$ arm::arrayH.data-vector)))) 419 439 420 440 441 #+can-encode-array-rank-trap 421 442 (define-arm-vinsn check-arrayH-rank (() 422 443 ((header :lisp) 423 444 (expected :u32const)) 424 445 ((rank :imm))) 425 (lwz rank arm::arrayH.rank header) 426 (twi 27 rank (:apply ash expected arm::fixnumshift))) 427 446 (ldr rank (:@ header (:$ arm::arrayH.rank))) 447 (cmp rank (:apply ash expected arm::fixnumshift)) 448 (uuo-error-bad-array-rank (:? ne) expected header)) 449 450 #+can-remember-what-this-means 428 451 (define-arm-vinsn check-arrayH-flags (() 429 452 ((header :lisp) … … 443 466 ((node :lisp) 444 467 (cellno :u32const))) 445 (l wz dest (:apply + arm::misc-data-offset (:apply ash cellno 2)) node))468 (ldr dest (:@ node (:$ (:apply + arm::misc-data-offset (:apply ash cellno 2)))))) 446 469 447 470 … … 451 474 (index :lisp)) 452 475 ((scaled :u32))) 453 (la scaled arm::misc-data-offset index) 454 (lwzx dest instance scaled) 455 (tweqi dest arm::slot-unbound-marker)) 476 (add scaled index (:$ arm::misc-data-offset)) 477 (ldr dest (:@ instance scaled)) 478 (cmp dest (:$ arm::slot-unbound-marker)) 479 (uuo-error-slot-unbound (:? eq) instance index)) 456 480 457 481 … … 461 485 ((src :address) 462 486 (index :s16const))) 463 (l wz dest index src))487 (ldr dest (:@ src (:$ index)))) 464 488 465 489 … … 467 491 ((src :address) 468 492 (index :s16const))) 469 (l wz dest index src))493 (ldr dest (:@ src (:$ index)))) 470 494 471 495 (define-arm-vinsn mem-ref-c-natural (((dest :u32)) 472 496 ((src :address) 473 497 (index :s16const))) 474 (l wz dest index src))498 (ldr dest (:@ src (:$ index)))) 475 499 476 500 … … 478 502 ((src :address) 479 503 (index :s32))) 480 (l wzx dest src index))504 (ldr dest (:@ src index))) 481 505 482 506 (define-arm-vinsn mem-ref-signed-fullword (((dest :u32)) 483 507 ((src :address) 484 508 (index :s32))) 485 (l wzx dest src index))509 (ldr dest (:@ src index))) 486 510 487 511 (define-arm-vinsn mem-ref-natural (((dest :u32)) 488 512 ((src :address) 489 513 (index :s32))) 490 (l wzx dest src index))514 (ldr dest (:@ src index))) 491 515 492 516 … … 494 518 ((src :address) 495 519 (index :s16const))) 496 (l hz dest index src))520 (ldrh dest (:@ src (:$ index)))) 497 521 498 522 … … 500 524 ((src :address) 501 525 (index :s32))) 502 (l hzx dest src index))526 (ldrh dest (:@ src index))) 503 527 504 528 … … 507 531 ((src :address) 508 532 (index :s16const))) 509 (l ha dest index src))533 (ldrsh dest (:@ src (:$ index)))) 510 534 511 535 (define-arm-vinsn mem-ref-s16 (((dest :s16)) 512 536 ((src :address) 513 537 (index :s32))) 514 (l hax dest src index))538 (ldrsh dest (:@ src index))) 515 539 516 540 (define-arm-vinsn mem-ref-c-u8 (((dest :u8)) 517 541 ((src :address) 518 542 (index :s16const))) 519 (l bz dest index src))543 (ldrb dest (:@ src (:$ index)))) 520 544 521 545 (define-arm-vinsn mem-ref-u8 (((dest :u8)) 522 546 ((src :address) 523 547 (index :s32))) 524 (l bzx dest src index))548 (ldrb dest (:@ src index))) 525 549 526 550 (define-arm-vinsn mem-ref-c-s8 (((dest :s8)) 527 551 ((src :address) 528 552 (index :s16const))) 529 (lbz dest index src) 530 (extsb dest dest)) 553 (ldrsb dest (:@ src (:$ index)))) 531 554 532 555 (define-arm-vinsn mem-ref-s8 (((dest :s8)) 533 556 ((src :address) 534 557 (index :s32))) 535 (l bzx dest src index)536 (extsb dest dest)) 537 558 (ldrsb dest (:@ src index))) 559 560 #+notyet 538 561 (define-arm-vinsn mem-ref-c-bit (((dest :u8)) 539 562 ((src :address) … … 543 566 (rlwinm dest dest bit-shift 31 31)) 544 567 568 569 #+notyet 545 570 (define-arm-vinsn mem-ref-c-bit-fixnum (((dest :lisp)) 546 571 ((src :address) … … 551 576 (rlwinm dest byteval bit-shift 29 29)) 552 577 578 #+notyet 553 579 (define-arm-vinsn mem-ref-bit (((dest :u8)) 554 580 ((src :address) … … 562 588 (rlwnm dest dest bit-shift 31 31)) 563 589 564 590 #+notyet 565 591 (define-arm-vinsn mem-ref-bit-fixnum (((dest :lisp)) 566 592 ((src :address) … … 580 606 (define-arm-vinsn mem-ref-c-double-float (((dest :double-float)) 581 607 ((src :address) 582 (index :s16const))) 583 (lfd dest index src)) 608 (index :s16const)) 609 ((low (:u32 #.arm::imm0)) 610 (high (:u32 #.arm::imm1)))) 611 (ldrd low (:@ src (:$ index))) 612 (fmdrr dest low high)) 584 613 585 614 (define-arm-vinsn mem-ref-double-float (((dest :double-float)) 586 615 ((src :address) 587 (index :s32))) 588 (lfdx dest src index)) 616 (index :s32)) 617 ((low (:u32 #.arm::imm0)) 618 (high (:u32 #.arm::imm1)))) 619 (ldrd low (:@ src index)) 620 (fmdrr dest low high)) 589 621 590 622 (define-arm-vinsn mem-set-c-double-float (() 591 623 ((val :double-float) 592 624 (src :address) 593 (index :s16const))) 594 (stfd val index src)) 625 (index :s16const)) 626 ((low (:u32 #.arm::imm0)) 627 (high (:u32 #.arm::imm1)))) 628 (fmrrd low high src) 629 (strd low (:@ src (:$ index)))) 595 630 596 631 (define-arm-vinsn mem-set-double-float (() 597 632 ((val :double-float) 598 633 (src :address) 599 (index :s32))) 600 (stfdx val src index)) 634 (index :s32)) ; imm2, I presume 635 ((low (:u32 #.arm::imm0)) 636 (high (:u32 #.arm::imm1)))) 637 (fmrrd low high src) 638 (strd low (:@ src index))) 601 639 602 640 (define-arm-vinsn mem-ref-c-single-float (((dest :single-float)) 603 641 ((src :address) 604 (index :s16const))) 605 (lfs dest index src)) 642 (index :s16const)) 643 ((temp :u32))) 644 (ldr temp (:@ src (:$ index))) 645 (fmsr dest temp)) 606 646 607 647 (define-arm-vinsn mem-ref-single-float (((dest :single-float)) 608 648 ((src :address) 609 (index :s32))) 610 (lfsx dest src index)) 649 (index :s32)) 650 ((temp :u32))) 651 (ldr temp (:@ src index)) 652 (fmsr dest temp)) 611 653 612 654 (define-arm-vinsn mem-set-c-single-float (() 613 655 ((val :single-float) 614 656 (src :address) 615 (index :s16const))) 616 (stfs val index src)) 657 (index :s16const)) 658 ((temp :u32))) 659 (fmrs temp src) 660 (str temp (:@ src (:$ index)))) 617 661 618 662 (define-arm-vinsn mem-set-single-float (() 619 663 ((val :single-float) 620 664 (src :address) 621 (index :s32))) 622 (stfsx val src index)) 665 (index :s32)) 666 ((temp :u32))) 667 (fmrs temp src) 668 (str temp (:@ src (:$ index)))) 623 669 624 670 … … 627 673 (src :address) 628 674 (index :s16const))) 629 (st w val index src))675 (str val (:@ src (:$ index)))) 630 676 631 677 (define-arm-vinsn mem-set-address (() … … 633 679 (src :address) 634 680 (index :s32))) 635 (st wx val src index))681 (str val (:@ src index))) 636 682 637 683 (define-arm-vinsn mem-set-c-fullword (() … … 639 685 (src :address) 640 686 (index :s16const))) 641 (st w val index src))687 (str val (:@ src (:$ index)))) 642 688 643 689 (define-arm-vinsn mem-set-fullword (() … … 645 691 (src :address) 646 692 (index :s32))) 647 (st wx val src index))693 (str val (:@ src index))) 648 694 649 695 (define-arm-vinsn mem-set-c-halfword (() … … 651 697 (src :address) 652 698 (index :s16const))) 653 (st h val index src))699 (strh val (:@ src (:$ index)))) 654 700 655 701 (define-arm-vinsn mem-set-halfword (() … … 657 703 (src :address) 658 704 (index :s32))) 659 (st hx val src index))705 (strh val (:@ src index))) 660 706 661 707 (define-arm-vinsn mem-set-c-byte (() … … 663 709 (src :address) 664 710 (index :s16const))) 665 (st b val index src))711 (strb val (:@ src (:$ index)))) 666 712 667 713 (define-arm-vinsn mem-set-byte (() … … 669 715 (src :address) 670 716 (index :s32))) 671 (stbx val src index)) 672 717 (strb val (:@ src index))) 718 719 #+later 673 720 (define-arm-vinsn mem-set-c-bit-0 (() 674 721 ((src :address) … … 681 728 (stb val byte-index src)) 682 729 730 #+later 683 731 (define-arm-vinsn mem-set-c-bit-1 (() 684 732 ((src :address) … … 690 738 (stb val byte-index src)) 691 739 740 #+later 692 741 (define-arm-vinsn mem-set-c-bit (() 693 742 ((src :address) … … 738 787 ((object :lisp))) 739 788 (and tag object (:$ arm::tagmask)) 740 (mov tag (:lsl $ tag arm::fixnumshift)))789 (mov tag (:lsl tag (:$ arm::fixnumshift)))) 741 790 742 791 (define-arm-vinsn extract-fulltag (((tag :u8)) … … 749 798 ((object :lisp))) 750 799 (and tag object (:$ arm::fulltagmask)) 751 (mov tag (:lsl $ tag arm::fixnumshift)))800 (mov tag (:lsl tag (:$ arm::fixnumshift)))) 752 801 753 802 (define-arm-vinsn extract-typecode (((code :u8)) … … 756 805 (and code object (:$ arm::tagmask)) 757 806 (cmp code (:$ arm::tag-misc)) 758 (ldrbeq code (:@ $ object arm::misc-subtag-offset)))807 (ldrbeq code (:@ object (:$ arm::misc-subtag-offset)))) 759 808 760 809 (define-arm-vinsn extract-typecode-fixnum (((code :imm)) … … 763 812 (and subtag object (:$ arm::tagmask)) 764 813 (cmp subtag (:$ arm::tag-misc)) 765 (ldrbeq subtag (:@ $ object arm::misc-subtag-offset))766 (mov code (:lsl $ subtag arm::fixnumshift)))814 (ldrbeq subtag (:@ object (:$ arm::misc-subtag-offset))) 815 (mov code (:lsl subtag (:$ arm::fixnumshift)))) 767 816 768 817 … … 781 830 (beq :got-it) 782 831 (cmp tag (:$ arm::tag-misc)) 783 (ldrbeq tag (: +@$ object arm::misc-subtag-offset))832 (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) 784 833 (cmp tag (:$ arm::subtag-bignum)) 785 834 (uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::xtype-integer)) … … 791 840 (and tag object (:$ arm::tagmask)) 792 841 (cmp tag (:$ arm::tag-misc)) 793 (ldrbeq tag (: +@$ object arm::misc-subtag-offset))842 (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) 794 843 (cmp tag (:$ arm::subtag-simple-vector)) 795 844 (uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::subtag-simple-vector))) … … 800 849 (and tag object (:$ arm::tagmask)) 801 850 (cmp tag (:$ arm::tag-misc)) 802 (ldrbeq tag (: +@$ object arm::misc-subtag-offset))851 (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) 803 852 (cmp tag (:$ arm::subtag-simple-base-string)) 804 853 (uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::subtag-simple-base-string))) … … 810 859 (and tag object (:$ arm::tagmask)) 811 860 (cmp tag (:$ arm::tag-misc)) 812 (ldrbeq tag (: +@$ object arm::misc-subtag-offset))861 (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) 813 862 (cmp tag (:$ arm::max-real-subtag)) 814 863 (uuo-cerror-reg-not-xtype (:? hi) object (:$ arm::xtype-real))) … … 819 868 (and tag object (:$ arm::tagmask)) 820 869 (cmp tag (:$ arm::tag-misc)) 821 (ldrbeq tag (: +@$ object arm::misc-subtag-offset))870 (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) 822 871 (cmp tag (:$ arm::max-numeric-subtag)) 823 872 (uuo-cerror-reg-not-xtype (:? hi) object (:$ arm::xtype-number))) … … 834 883 ((object :lisp)) 835 884 ((tag :u8))) 836 (and tag object (:$ arm:: lisptagmask))885 (and tag object (:$ arm::tagmask)) 837 886 (cmp tag (:$ arm::tag-misc)) 838 887 (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) … … 853 902 ((tag :u32))) 854 903 (mov tag (:lsl object (:$ (- arm::nbits-in-word (+ 8 arm::fixnumshift))))) 855 (mov tag (:asr tag ( - arm::nbits-in-word (+ 8 arm::fixnumshift))))904 (mov tag (:asr tag (:$ (- arm::nbits-in-word (+ 8 arm::fixnumshift))))) 856 905 (cmp object (:lsl tag (:$ arm::fixnumshift))) 857 906 (uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::xtype-s8))) … … 859 908 860 909 (define-arm-vinsn require-u8 (() 861 ((object :lisp))) 862 (tst object (:$ (lognot (ash #xff arm::fixnumshift)))) 910 ((object :lisp)) 911 ((temp :u32))) 912 (mov temp (:$ (lognot (ash #xff arm::fixnumshift)))) 913 (tst object temp) 863 914 (uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::xtype-u8))) 864 915 … … 890 941 (ldreq header (:@ src (:$ arm::misc-header-offset))) 891 942 (cmpeq tag header) 892 (uuo-cerror- object-not-xtype (:? ne) src (:$ arm::xtype-s32))943 (uuo-cerror-reg-not-xtype (:? ne) src (:$ arm::xtype-s32)) 893 944 :got-it) 894 945 … … 898 949 ((temp :u32))) 899 950 :again 900 (t est src (:$ (logior (ash 1 (1- arm::nbits-in-word)) arm::tagmask)))951 (tst src (:$ (logior (ash 1 (1- arm::nbits-in-word)) arm::tagmask))) 901 952 (beq :got-it) 902 953 (and temp src (:$ arm::tagmask)) … … 905 956 (cmp temp (:$ arm::subtag-bignum)) 906 957 (bne :bad-if-ne) 907 (ldr temp (:@ src arm::misc-header-offset))958 (ldr temp (:@ src (:$ arm::misc-header-offset))) 908 959 (mov temp (:lsr temp (:$ arm::num-subtag-bits))) 909 960 (cmp temp (:$ 2)) … … 930 981 (ldreq header (:@ src (:$ arm::misc-header-offset))) 931 982 (andeq tag header (:$ arm::subtag-mask)) 932 (cmp tag (:$ arm::subtag _bignum))933 (mov eheader (:lsr header (:$ arm::num-subtag-bits)))983 (cmp tag (:$ arm::subtag-bignum)) 984 (mov header (:lsr header (:$ arm::num-subtag-bits))) 934 985 (bne :bad-if-ne) 935 986 (cmp header (:$ 1)) … … 949 1000 (beq :got-it) 950 1001 (cmp temp (:$ arm::tag-misc)) 951 (ldreq header (:@ src (:$ arm::misc-header-offset 0)))1002 (ldreq header (:@ src (:$ arm::misc-header-offset))) 952 1003 (andeq temp src (:$ arm::subtag-mask)) 953 1004 (moveq header (:lsr header (:$ arm::num-subtag-bits))) … … 1013 1064 (cmp temp (:$ arm::tag-misc)) 1014 1065 (uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-u32)) 1015 (ldr dest (: +@$ src arm::misc-header-offset))1016 ( ldrtemp (:$ arm::subtag-bignum))1066 (ldr dest (:@ src (:$ arm::misc-header-offset))) 1067 (mov temp (:$ arm::subtag-bignum)) 1017 1068 (orr temp temp (:$ (ash 1 arm::num-subtag-bits))) 1018 1069 (cmp dest temp) 1019 1070 (bne :maybe-two-digit) 1020 (ldr dest (: +@$ src arm::misc-data-offset))1071 (ldr dest (:@ src (:$ arm::misc-data-offset))) 1021 1072 (tst dest (:$ 31)) 1022 1073 (uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-u32)) … … 1025 1076 (add temp temp (:$ (ash 1 arm::num-subtag-bits))) 1026 1077 (cmp dest temp) 1027 (ldreq temp (: +@$ src (+ arm::misc-data-offset 4)))1078 (ldreq temp (:@ src (:$ (+ arm::misc-data-offset 4)))) 1028 1079 (cmpeq temp (:$ 0)) 1029 (ldreq dest (: +@$ src arm::misc-data-offset))1080 (ldreq dest (:@ src (:$ arm::misc-data-offset))) 1030 1081 (uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-u32)) 1031 :got-it) )1082 :got-it) 1032 1083 1033 1084 ;;; an object is of type (SIGNED-BYTE 32) iff … … 1039 1090 ((tag :u32))) 1040 1091 (ands tag src (:$ arm::tagmask)) 1041 (mov dest (:asr $ src arm::fixnumshift))1092 (mov dest (:asr src (:$ arm::fixnumshift))) 1042 1093 (beq :got-it) 1043 1094 (mov dest (:$ arm::subtag-bignum)) 1044 1095 (orr dest dest (:$ (ash 1 arm::num-subtag-bits))) 1045 1096 (cmp tag (:$ arm::tag-misc)) 1046 (ldreq tag (: +@ src (:$ arm::misc-header-offset)))1097 (ldreq tag (:@ src (:$ arm::misc-header-offset))) 1047 1098 (cmpeq dest tag) 1048 (ldreq dest (: +@ src (:$ arm::misc-data-offset)))1099 (ldreq dest (:@ src (:$ arm::misc-data-offset))) 1049 1100 (uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-s32)) 1050 :got-it) )1101 :got-it) 1051 1102 1052 1103 … … 1083 1134 ((src :lisp))) 1084 1135 (mov dest (:lsl dest (:$ (- 24 arm::fixnumshift)))) 1085 (mov dest (: $asr dest (:$ 24)))1136 (mov dest (:asr dest (:$ 24))) 1086 1137 (cmp src (:lsl dest (:$ arm::fixnumshift))) 1087 1138 (uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-s8))) … … 1092 1143 (cmp dest (:$ arm::subtag-character)) 1093 1144 (mov dest (:lsr src (:$ arm::charcode-shift))) 1094 (uuo-error- object-not-xtype (:? ne) src (:$ arm::subtag-character)))1145 (uuo-error-reg-not-xtype (:? ne) src (:$ arm::subtag-character))) 1095 1146 1096 1147 … … 1101 1152 (uuo-error-reg-not-xtype (:? hi) src (:$ arm::xtype-bit))) 1102 1153 1154 #+later 1103 1155 (define-arm-vinsn unbox-bit-bit0 (((dest :u32)) 1104 1156 ((src :lisp)) … … 1110 1162 :got-it) 1111 1163 1112 (define-arm-vinsn fixnum->fpr (((dest :double-float)) 1113 ((src :lisp)) 1114 ((imm :s32))) 1115 (stfd arm::fp-s32conv -8 arm::sp) 1116 (srawi imm src arm::fixnumshift) 1117 (xoris imm imm #x8000) 1118 (stw imm -4 arm::sp) 1119 (lfd dest -8 arm::sp) 1120 (fsub dest dest arm::fp-s32conv)) 1164 (define-arm-vinsn fixnum->double (((dest :double-float)) 1165 ((src :lisp)) 1166 ((imm :s32) 1167 (temp :single-float))) 1168 (mov imm (:asr src (:$ arm::fixnumshift))) 1169 (fmsr temp imm) 1170 (fsitod dest temp)) 1171 1172 (define-arm-vinsn fixnum->single (((dest :single-float)) 1173 ((src :lisp)) 1174 ((imm :s32))) 1175 (mov imm (:asr src (:$ arm::fixnumshift))) 1176 (fmsr dest imm) 1177 (fsitos dest dest)) 1121 1178 1122 1179 … … 1124 1181 ((src :u32) 1125 1182 (sh :u32))) 1126 ( srw dest src sh))1183 (mov dest (:lsr src sh))) 1127 1184 1128 1185 (define-arm-vinsn u32logandc2 (((dest :u32)) 1129 1186 ((x :u32) 1130 1187 (y :u32))) 1131 ( andc dest x y))1188 (bic dest x y)) 1132 1189 1133 1190 (define-arm-vinsn u32logior (((dest :u32)) 1134 1191 ((x :u32) 1135 1192 (y :u32))) 1136 (or dest x y)) 1137 1138 (define-arm-vinsn rotate-left-variable-word (((dest :u32)) 1139 ((src :u32) 1140 (rot :u32))) 1141 (rlwnm dest src rot 0 31)) 1193 (orr dest x y)) 1142 1194 1143 1195 (define-arm-vinsn complement-shift-count (((dest :u32)) 1144 1196 ((src :u32))) 1145 ( subfic dest src 32))1197 (rsb dest src (:$ 32))) 1146 1198 1147 1199 (define-arm-vinsn extract-lowbyte (((dest :u32)) 1148 1200 ((src :lisp))) 1149 (clrlwi dest src (- arm::nbits-in-word arm::num-subtag-bits))) 1150 1151 ;;; Set DEST to the difference between the low byte of SRC and BYTEVAL. 1152 (define-arm-vinsn extract-compare-lowbyte (((dest :u32)) 1153 ((src :lisp) 1154 (byteval :u8const))) 1155 (clrlwi dest src (- arm::nbits-in-word arm::num-subtag-bits)) 1156 (subi dest dest byteval)) 1157 1158 1159 ;;; Set the "EQ" bit in condition-register field CRF if object is 1160 ;;; a fixnum. Leave the object's tag in TAG. 1161 ;;; This is a little easier if CRF is CR0. 1162 (define-arm-vinsn eq-if-fixnum (((crf :crf) 1163 (tag :u8)) 1164 ((object :lisp)) 1165 ()) 1166 ((:eq crf 0) 1167 (clrlwi. tag object (- arm::nbits-in-word arm::nlisptagbits))) 1168 ((:not (:eq crf 0)) 1169 (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) 1170 (cmpwi crf tag arm::tag-fixnum))) 1201 (and dest src (:$ arm::subtag-mask))) 1202 1171 1203 1172 1204 1173 1205 1174 1206 (define-arm-vinsn trap-unless-fixnum (() 1175 ((object :lisp)) 1176 ((tag :u8))) 1177 (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) 1178 (twnei tag arm::tag-fixnum)) 1207 ((object :lisp))) 1208 (tst object (:$ arm::fixnummask)) 1209 (uuo-error-reg-not-lisptag (:? ne) object (:$ arm::tag-fixnum))) 1179 1210 1180 1211 (define-arm-vinsn trap-unless-list (() 1181 1212 ((object :lisp)) 1182 1213 ((tag :u8))) 1183 (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) 1184 (twnei tag arm::tag-list)) 1214 (ands tag object (:$ arm::tagmask)) 1215 (cmp tag (:$ arm::tag-list)) 1216 (uuo-error-reg-not-lisptag (:? ne) object (:$ arm::tag-list))) 1185 1217 1186 1218 (define-arm-vinsn trap-unless-single-float (() 1187 1219 ((object :lisp)) 1188 ((tag :u8) 1189 (crf :crf))) 1190 (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) 1191 (cmpwi crf tag arm::tag-misc) 1192 (bne crf :do-trap) 1193 (lbz tag arm::misc-subtag-offset object) 1194 :do-trap 1195 (twnei tag arm::subtag-single-float)) 1220 ((tag :u8))) 1221 (and tag object (:$ arm::tagmask)) 1222 (cmp tag (:$ arm::tag-misc)) 1223 (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) 1224 (cmp tag (:$ arm::subtag-single-float)) 1225 (uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-single-float))) 1196 1226 1197 1227 (define-arm-vinsn trap-unless-double-float (() 1198 1228 ((object :lisp)) 1199 ((tag :u8) 1200 (crf :crf))) 1201 (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) 1202 (cmpwi crf tag arm::tag-misc) 1203 (bne crf :do-trap) 1204 (lbz tag arm::misc-subtag-offset object) 1205 :do-trap 1206 (twnei tag arm::subtag-double-float)) 1229 ((tag :u8))) 1230 (and tag object (:$ arm::tagmask)) 1231 (cmp tag (:$ arm::tag-misc)) 1232 (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) 1233 (cmp tag (:$ arm::subtag-double-float)) 1234 (uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-double-float))) 1207 1235 1208 1236 1209 1237 (define-arm-vinsn trap-unless-array-header (() 1210 1238 ((object :lisp)) 1211 ((tag :u8) 1212 (crf :crf))) 1213 (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) 1214 (cmpwi crf tag arm::tag-misc) 1215 (bne crf :do-trap) 1216 (lbz tag arm::misc-subtag-offset object) 1217 :do-trap 1218 (twnei tag arm::subtag-arrayH)) 1239 ((tag :u8))) 1240 (and tag object (:$ arm::tagmask)) 1241 (cmp tag (:$ arm::tag-misc)) 1242 (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) 1243 (cmp tag (:$ arm::subtag-arrayH)) 1244 (uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-arrayH))) 1219 1245 1220 1246 (define-arm-vinsn trap-unless-macptr (() 1221 1247 ((object :lisp)) 1222 ((tag :u8) 1223 (crf :crf))) 1224 (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) 1225 (cmpwi crf tag arm::tag-misc) 1226 (bne crf :do-trap) 1227 (lbz tag arm::misc-subtag-offset object) 1228 :do-trap 1229 (twnei tag arm::subtag-macptr)) 1248 ((tag :u8))) 1249 (and tag object (:$ arm::tagmask)) 1250 (cmp tag (:$ arm::tag-misc)) 1251 (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) 1252 (cmp tag (:$ arm::subtag-macptr)) 1253 (uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-macptr))) 1230 1254 1231 1255 … … 1234 1258 ((object :lisp)) 1235 1259 ((tag :u8))) 1236 (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) 1237 (twnei tag arm::tag-misc)) 1238 1239 (define-arm-vinsn trap-unless-fulltag= (() 1240 ((object :lisp) 1241 (tagval :u16const)) 1242 ((tag :u8))) 1243 (clrlwi tag object (- arm::nbits-in-word arm::ntagbits)) 1244 (twnei tag tagval)) 1245 1246 (define-arm-vinsn trap-unless-lowbyte= (() 1247 ((object :lisp) 1248 (tagval :u16const)) 1249 ((tag :u8))) 1250 (clrlwi tag object (- arm::nbits-in-word 8)) 1251 (twnei tag tagval)) 1260 (and tag object (:$ arm::tagmask)) 1261 (cmp tag (:$ arm::tag-misc)) 1262 (uuo-error-reg-not-lisptag (:? ne) object (:$ arm::tag-misc))) 1263 1264 1252 1265 1253 1266 (define-arm-vinsn trap-unless-character (() 1254 1267 ((object :lisp)) 1255 1268 ((tag :u8))) 1256 (clrlwi tag object (- arm::nbits-in-word 8)) 1257 (twnei tag arm::subtag-character)) 1269 (and tag object (:$ arm::subtag-mask)) 1270 (cmp tag (:$ arm::subtag-character)) 1271 (uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-character))) 1258 1272 1259 1273 (define-arm-vinsn trap-unless-cons (() 1260 1274 ((object :lisp)) 1261 1275 ((tag :u8))) 1262 (clrlwi tag object (- arm::nbits-in-word arm::ntagbits)) 1263 (twnei tag arm::fulltag-cons)) 1276 (and tag object (:$ arm::fulltagmask)) 1277 (cmp tag (:$ arm::fulltag-cons)) 1278 (uuo-error-reg-not-fulltag (:? ne) object (:$ arm::fulltag-cons))) 1264 1279 1265 1280 (define-arm-vinsn trap-unless-typecode= (() 1266 1281 ((object :lisp) 1267 1282 (tagval :u16const)) 1268 ((tag :u8) 1269 (crf :crf))) 1270 (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) 1271 (cmpwi crf tag arm::tag-misc) 1272 (bne crf :do-trap) 1273 (lbz tag arm::misc-subtag-offset object) 1274 :do-trap 1275 (twnei tag tagval)) 1283 ((tag :u8))) 1284 (and tag object (:$ arm::tagmask)) 1285 (cmp tag (:$ arm::tag-misc)) 1286 (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) 1287 (cmp tag (:$ tagval)) 1288 (uuo-error-reg-not-xtype (:? ne) object (:$ tagval))) 1276 1289 1277 1290 (define-arm-vinsn subtract-constant (((dest :imm)) 1278 1291 ((src :imm) 1279 1292 (const :s16const))) 1280 (subi dest src const)) 1281 1282 (define-arm-vinsn trap-unless-numeric-type (() 1283 ((object :lisp) 1284 (maxtype :u16const)) 1285 ((crf0 (:crf 0)) 1286 (tag :u8) 1287 (crfX :crf))) 1288 (clrlwi. tag object (- arm::nbits-in-word arm::nlisptagbits)) 1289 (cmpwi tag arm::tag-misc) 1290 (beq+ crf0 :fixnum) 1291 (bne crfX :scale-tag) 1292 (lbz tag arm::misc-subtag-offset object) 1293 :scale-tag 1294 (subi tag tag arm::min-numeric-subtag) 1295 (twlgti tag (:apply - maxtype arm::min-numeric-subtag)) 1296 :fixnum) 1293 (sub dest src (:$ const))) 1294 1297 1295 1298 1296 1299 1297 ;; Bit-extraction & boolean operations 1300 1298 1301 (eval-when (:compile-toplevel :execute)1302 (assert (= arm::t-offset #b10001))) ; ARM-bits 31 and 27 set1303 1299 1304 1300 ;; For some mind-numbing reason, IBM decided to call the most significant … … 1311 1307 ;; 31.)) 1312 1308 1309 #+later 1313 1310 (define-arm-vinsn extract-variable-bit (((dest :u8)) 1314 1311 ((src :u32) … … 1318 1315 (extrwi dest dest 1 0)) 1319 1316 1320 1317 #+later 1321 1318 (define-arm-vinsn extract-variable-bit-fixnum (((dest :imm)) 1322 1319 ((src :u32) … … 1337 1334 ;; between T and NIL) or 0. 1338 1335 1336 #+later 1339 1337 (define-arm-vinsn lowbit->truth (((dest :lisp) 1340 1338 (bits :u32)) … … 1344 1342 (addi dest bits (:apply target-nil-value))) 1345 1343 1344 #+later 1346 1345 (define-arm-vinsn invert-lowbit (((bits :u32)) 1347 1346 ((bits :u32)) … … 1351 1350 1352 1351 1353 ;; Some of the obscure-looking instruction sequences - which map some relation 1354 ;; to ARM bit 31 of some register - were found by the GNU SuperOptimizer. 1355 ;; Some of them use extended-precision instructions (which may cause interlocks 1356 ;; on some superscalar ARMs, if I remember correctly.) In general, sequences 1357 ;; that GSO found that -don't- do extended precision are longer and/or use 1358 ;; more temporaries. 1359 ;; On the 604, the penalty for using an instruction that uses the CA bit is 1360 ;; "at least" one cycle: it can't complete execution until all "older" instructions 1361 ;; have. That's not horrible, especially given that the alternative is usually 1362 ;; to use more instructions (and, more importantly, more temporaries) to avoid 1363 ;; using extended-precision. 1364 1365 1366 (define-arm-vinsn eq0->bit31 (((bits :u32)) 1367 ((src (t (:ne bits))))) 1368 (cntlzw bits src) 1369 (srwi bits bits 5)) ; bits = 0000...000X 1370 1371 (define-arm-vinsn ne0->bit31 (((bits :u32)) 1372 ((src (t (:ne bits))))) 1373 (cntlzw bits src) 1374 (slw bits src bits) 1375 (srwi bits bits 31)) ; bits = 0000...000X 1376 1377 (define-arm-vinsn lt0->bit31 (((bits :u32)) 1378 ((src (t (:ne bits))))) 1379 (srwi bits src 31)) ; bits = 0000...000X 1380 1381 1352 (define-arm-vinsn eq0->boolean (((dest t)) 1353 ((src t))) 1354 (cmp src (:$ 0)) 1355 (mov dest (:$ arm::nil-value)) 1356 (addeq dest dest (:$ arm::t-offset))) 1357 1358 1359 (define-arm-vinsn ne0->boolean (((dest t)) 1360 ((src t))) 1361 (cmp src (:$ 0)) 1362 (mov dest (:$ arm::nil-value)) 1363 (addne dest dest (:$ arm::t-offset))) 1364 1365 (define-arm-vinsn lt0->boolean (((dest t)) 1366 ((src t))) 1367 (cmp src (:$ 0)) 1368 (mov dest (:$ arm::nil-value)) 1369 (addmi dest dest (:$ arm::t-offset))) 1370 1371 1372 #+later 1382 1373 (define-arm-vinsn ge0->bit31 (((bits :u32)) 1383 1374 ((src (t (:ne bits))))) … … 1385 1376 (xori bits bits 1)) ; bits = 0000...000X 1386 1377 1387 1378 #+later 1388 1379 (define-arm-vinsn le0->bit31 (((bits :u32)) 1389 1380 ((src (t (:ne bits))))) … … 1392 1383 (srwi bits bits 31)) ; bits = 0000...000X 1393 1384 1385 #+later 1394 1386 (define-arm-vinsn gt0->bit31 (((bits :u32)) 1395 1387 ((src (t (:ne bits))))) … … 1398 1390 (srwi bits bits 31)) ; bits = 0000...000X 1399 1391 1392 #+later 1400 1393 (define-arm-vinsn ne->bit31 (((bits :u32)) 1401 1394 ((x t) … … 1407 1400 (srwi bits bits 31)) ; bits = 0000...000X 1408 1401 1402 #+later 1409 1403 (define-arm-vinsn fulltag->bit31 (((bits :u32)) 1410 1404 ((lispobj :lisp) … … 1416 1410 (srwi bits bits 5)) 1417 1411 1418 1412 #+later 1419 1413 (define-arm-vinsn eq->bit31 (((bits :u32)) 1420 1414 ((x t) … … 1424 1418 (srwi bits bits 5)) ; bits = 0000...000X 1425 1419 1420 #+later 1426 1421 (define-arm-vinsn eqnil->bit31 (((bits :u32)) 1427 1422 ((x t))) … … 1430 1425 (srwi bits bits 5)) 1431 1426 1427 #+later 1432 1428 (define-arm-vinsn ne->bit31 (((bits :u32)) 1433 1429 ((x t) … … 1438 1434 (xori bits bits 1)) 1439 1435 1436 #+later 1440 1437 (define-arm-vinsn nenil->bit31 (((bits :u32)) 1441 1438 ((x t))) … … 1445 1442 (xori bits bits 1)) 1446 1443 1444 #+later 1447 1445 (define-arm-vinsn lt->bit31 (((bits :u32)) 1448 1446 ((x (t (:ne bits))) … … 1455 1453 (srwi bits bits 31)) ; bits = 0000...000X 1456 1454 1455 #+later 1457 1456 (define-arm-vinsn ltu->bit31 (((bits :u32)) 1458 1457 ((x :u32) … … 1462 1461 (neg bits bits)) 1463 1462 1463 #+later 1464 1464 (define-arm-vinsn le->bit31 (((bits :u32)) 1465 1465 ((x (t (:ne bits))) … … 1472 1472 (srwi bits bits 31)) ; bits = 0000...000X 1473 1473 1474 #+later 1474 1475 (define-arm-vinsn leu->bit31 (((bits :u32)) 1475 1476 ((x :u32) … … 1478 1479 (addze bits arm::rzero)) 1479 1480 1481 #+later 1480 1482 (define-arm-vinsn gt->bit31 (((bits :u32)) 1481 1483 ((x (t (:ne bits))) … … 1488 1490 (srwi bits bits 31)) ; bits = 0000...000X 1489 1491 1492 #+later 1490 1493 (define-arm-vinsn gtu->bit31 (((bits :u32)) 1491 1494 ((x :u32) … … 1495 1498 (neg bits bits)) 1496 1499 1500 #+later 1497 1501 (define-arm-vinsn ge->bit31 (((bits :u32)) 1498 1502 ((x (t (:ne bits))) … … 1504 1508 (srwi bits bits 31)) ; bits = 0000...000X 1505 1509 1510 #+later 1506 1511 (define-arm-vinsn geu->bit31 (((bits :u32)) 1507 1512 ((x :u32) … … 1517 1522 ;;; MFCR takes three cycles and waits for previous instructions to complete. 1518 1523 ;;; Of course, using a CR field costs us something as well. 1524 #+later 1519 1525 (define-arm-vinsn crbit->bit31 (((bits :u32)) 1520 1526 ((crf :crf) … … 1525 1531 1526 1532 1527 (define-arm-vinsn compare (( (crf :crf))1533 (define-arm-vinsn compare (() 1528 1534 ((arg0 t) 1529 1535 (arg1 t)) 1530 1536 ()) 1531 (cmp w crfarg0 arg1))1532 1533 (define-arm-vinsn compare-to-nil (( (crf :crf))1537 (cmp arg0 arg1)) 1538 1539 (define-arm-vinsn compare-to-nil (() 1534 1540 ((arg0 t))) 1535 (cmp wi crf arg0 (:apply target-nil-value)))1536 1537 (define-arm-vinsn compare-logical ( ((crf :crf))1541 (cmp arg0 (:$ arm::nil-value))) 1542 1543 (define-arm-vinsn compare-logical ( 1538 1544 ((arg0 t) 1539 1545 (arg1 t)) 1540 1546 ()) 1541 (cmp lw crfarg0 arg1))1542 1543 (define-arm-vinsn double-float-compare (( (crf :crf))1547 (cmp arg0 arg1)) 1548 1549 (define-arm-vinsn double-float-compare (() 1544 1550 ((arg0 :double-float) 1545 1551 (arg1 :double-float)) 1546 1552 ()) 1547 (fcmpo crf arg0 arg1)) 1553 (fcmped arg0 arg1) 1554 (fmstat)) 1548 1555 1549 1556 … … 1571 1578 ((x :single-float) 1572 1579 (y :single-float)) 1573 ( (crf (:crf 4))))1580 ()) 1574 1581 (fadds result x y)) 1575 1582 … … 1593 1600 1594 1601 1595 (define-arm-vinsn compare-unsigned (( (crf :crf))1602 (define-arm-vinsn compare-unsigned (() 1596 1603 ((arg0 :imm) 1597 1604 (arg1 :imm)) 1598 1605 ()) 1599 (cmp lw crfarg0 arg1))1600 1601 (define-arm-vinsn compare-signed-s16const (( (crf :crf))1606 (cmp arg0 arg1)) 1607 1608 (define-arm-vinsn compare-signed-s16const (() 1602 1609 ((arg0 :imm) 1603 1610 (imm :s16const)) 1604 1611 ()) 1605 (cmp wi crf arg0 imm))1606 1607 (define-arm-vinsn compare-unsigned-u16const (( (crf :crf))1612 (cmp arg0 (:$ imm))) 1613 1614 (define-arm-vinsn compare-unsigned-u16const (() 1608 1615 ((arg0 :u32) 1609 1616 (imm :u16const)) 1610 1617 ()) 1611 (cmp lwi crf arg0 imm))1618 (cmp arg0 (:$ imm))) 1612 1619 1613 1620 … … 1615 1622 ;; Extract a constant bit (0-31) from src; make it be bit 31 of dest. 1616 1623 ;; Bitnum is treated mod 32. 1624 #+later 1617 1625 (define-arm-vinsn extract-constant-arm-bit (((dest :u32)) 1618 1626 ((src :imm) … … 1622 1630 1623 1631 1632 #+later 1624 1633 (define-arm-vinsn set-constant-arm-bit-to-variable-value (((dest :u32)) 1625 1634 ((src :u32) … … 1628 1637 (rlwimi dest bitval (:apply - 32 bitnum) bitnum bitnum)) 1629 1638 1639 #+later 1630 1640 (define-arm-vinsn set-constant-arm-bit-to-1 (((dest :u32)) 1631 1641 ((src :u32) … … 1636 1646 (ori dest src (:apply ash #x8000 (:apply - (:apply - bitnum 16)))))) 1637 1647 1648 #+later 1638 1649 (define-arm-vinsn set-constant-arm-bit-to-0 (((dest :u32)) 1639 1650 ((src :u32) … … 1641 1652 (rlwinm dest src 0 (:apply logand #x1f (:apply 1+ bitnum)) (:apply logand #x1f (:apply 1- bitnum)))) 1642 1653 1643 1654 1655 #+later 1644 1656 (define-arm-vinsn insert-bit-0 (((dest :u32)) 1645 1657 ((src :u32) … … 1654 1666 ;;; I think ... 1655 1667 ;;; Actually, it'd be "unbox, then subtract from 30". 1668 #+later 1656 1669 (define-arm-vinsn extract-variable-non-insane-bit (((dest :u32)) 1657 1670 ((src :imm) … … 1666 1679 (define-arm-vinsn %cdr (((dest :lisp)) 1667 1680 ((src :lisp))) 1668 (ldr dest (: +@$ src arm::cons.cdr)))1681 (ldr dest (:@ src (:$ arm::cons.cdr)))) 1669 1682 1670 1683 (define-arm-vinsn %car (((dest :lisp)) 1671 1684 ((src :lisp))) 1672 (ldr dest (: +@$ src arm::cons.car)))1685 (ldr dest (:@ src (:$ arm::cons.car)))) 1673 1686 1674 1687 (define-arm-vinsn %set-car (() 1675 1688 ((cell :lisp) 1676 1689 (new :lisp))) 1677 (str dest (:+@$ src arm::cons.car)))1690 (str cell (:@ new (:$ arm::cons.car)))) 1678 1691 1679 1692 (define-arm-vinsn %set-cdr (() 1680 1693 ((cell :lisp) 1681 1694 (new :lisp))) 1682 (str dest (:+@$ src arm::cons.cdr))) 1683 1695 (str cell (:@ new (:$ arm::cons.cdr)))) 1696 1697 #+later 1684 1698 (define-arm-vinsn load-adl (() 1685 1699 ((n :u32const))) … … 1689 1703 (define-arm-vinsn set-nargs (() 1690 1704 ((n :s16const))) 1691 ( li nargs (:apply ash n arm::word-shift)))1705 (mov nargs (:$ (:apply ash n arm::word-shift)))) 1692 1706 1693 1707 (define-arm-vinsn scale-nargs (() 1694 1708 ((nfixed :s16const))) 1695 1709 ((:pred > nfixed 0) 1696 (add nargs narg (:$ (:apply - (:apply ash nfixed arm::word-shift))))))1710 (add nargs nargs (:$ (:apply - (:apply ash nfixed arm::word-shift)))))) 1697 1711 1698 1712 … … 1701 1715 (() 1702 1716 ((reg :lisp))) 1703 (str reg (: +@! vsp (:$ (- arm::node-size)))))1717 (str reg (:@! vsp (:$ (- arm::node-size))))) 1704 1718 1705 1719 (define-arm-vinsn (vpush-register-arg :push :node :vsp :outgoing-argument) 1706 1720 (() 1707 1721 ((reg :lisp))) 1708 (str reg (: +@! vsp (:$ (- arm::node-size)))))1722 (str reg (:@! vsp (:$ (- arm::node-size))))) 1709 1723 1710 1724 (define-arm-vinsn (vpop-register :pop :node :vsp) … … 1734 1748 (:apply %hard-regspec-value dest) 1735 1749 (:apply %hard-regspec-value src))) 1736 (f mrdest src)))1750 (fcpyd dest src))) 1737 1751 1738 1752 (define-arm-vinsn vcell-ref (((dest :lisp)) 1739 1753 ((vcell :lisp))) 1740 (l wz dest arm::misc-data-offset vcell))1754 (ldr dest (:@ vcell (:$ arm::misc-data-offset)))) 1741 1755 1742 1756 … … 1744 1758 ((closed (:lisp :ne dest))) 1745 1759 ((header :u32))) 1746 (li header arm::value-cell-header) 1747 (la arm::allocptr (- arm::fulltag-misc arm::value-cell.size) arm::allocptr) 1748 (twllt arm::allocptr arm::allocbase) 1749 (stw header arm::misc-header-offset arm::allocptr) 1750 (mr dest arm::allocptr) 1751 (clrrwi arm::allocptr arm::allocptr arm::ntagbits) 1752 (stw closed arm::value-cell.value dest)) 1753 1754 (define-arm-vinsn make-tsp-vcell (((dest :lisp)) 1755 ((closed :lisp)) 1756 ((header :u32))) 1757 (li header arm::value-cell-header) 1758 (stwu arm::tsp -16 arm::tsp) 1759 (stw arm::tsp 4 arm::tsp) 1760 (stfd arm::fp-zero 8 arm::tsp) 1761 (stw arm::rzero 4 arm::tsp) 1762 (stw header (+ 8 arm::fulltag-misc arm::value-cell.header) arm::tsp) 1763 (stw closed (+ 8 arm::fulltag-misc arm::value-cell.value) arm::tsp) 1764 (la dest (+ 8 arm::fulltag-misc) arm::tsp)) 1765 1766 (define-arm-vinsn make-tsp-cons (((dest :lisp)) 1767 ((car :lisp) (cdr :lisp)) 1768 ()) 1769 (stwu arm::tsp -16 arm::tsp) 1770 (stw arm::tsp 4 arm::tsp) 1771 (stfd arm::fp-zero 8 arm::tsp) 1772 (stw arm::rzero 4 arm::tsp) 1773 (stw car (+ 8 arm::fulltag-cons arm::cons.car) arm::tsp) 1774 (stw cdr (+ 8 arm::fulltag-cons arm::cons.cdr) arm::tsp) 1775 (la dest (+ 8 arm::fulltag-cons) arm::tsp)) 1760 (mov header (:$ arm::subtag-value-cell)) 1761 (orr header header (:$ (ash arm::value-cell.element-count arm::num-subtag-bits))) 1762 (sub allocptr allocptr (:$ (- arm::value-cell.size arm::fulltag-misc))) 1763 (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) 1764 (cmp allocptr dest) 1765 (uuo-alloc-trap (:? lo)) 1766 (str header (:@ allocptr (:$ arm::misc-header-offset))) 1767 (mov dest allocptr) 1768 (bic allocptr allocptr (:$ arm::fulltagmask)) 1769 (str closed (:@ dest (:$ arm::value-cell.value)))) 1770 1771 (define-arm-vinsn make-stack-vcell (((dest :lisp)) 1772 ((closed :lisp)) 1773 ((header :u32))) 1774 (mov header (:$ arm::subtag-value-cell)) 1775 (orr header header (:$ (ash arm::value-cell.element-count arm::num-subtag-bits))) 1776 (stmdb (:! sp) (closed header))) 1777 1778 (define-arm-vinsn make-stack-cons (((dest :lisp)) 1779 ((car :lisp) (cdr :lisp)) 1780 ((header (:u32 #.arm::imm0)) 1781 (zero (:u32 #.arm::imm1)))) 1782 (mov header (:$ arm::subtag-simple-vector)) 1783 (mov zero (:$ 0)) 1784 (orr header header (:$ (ash 3 arm::num-subtag-bits))) 1785 ((:pred < 1786 (:apply %hard-regspec-value cdr) 1787 (:apply %hard-regpsec-value car)) 1788 (stmdb (:! sp) (car cdr zero header))) 1789 ((:not (:pred < 1790 (:apply %hard-regspec-value cdr) 1791 (:apply %hard-regpsec-value car))) 1792 (stmdb (:! sp) (cdr car zero header)) 1793 (str car (:@ sp (:$ 12))) 1794 (str cdr (:@ sp (:$ 8)))) 1795 (add dest sp (:$ (+ arm::dnode-size arm::fulltag-cons)))) 1776 1796 1777 1797 1778 1798 (define-arm-vinsn %closure-code% (((dest :lisp)) 1779 1799 ()) 1780 (lwz dest (:apply + arm::symbol.vcell (arm::nrs-offset %closure-code%) (:apply target-nil-value)) 0)) 1800 (mov dest (:$ arm::nil-value)) 1801 (ldr dest (:@ dest (:$ (:apply + arm::symbol.vcell (arm::nrs-offset %closure-code%)))))) 1781 1802 1782 1803 1783 1804 (define-arm-vinsn single-float-bits (((dest :u32)) 1784 1805 ((src :lisp))) 1785 (l wz dest arm::single-float.value src))1806 (ldr dest (:@ src (:$ arm::single-float.value)))) 1786 1807 1787 1808 (define-arm-vinsn (call-subprim :call :subprim-call) (() … … 1822 1843 () 1823 1844 ((temp :u32))) 1824 (l wz temp arm::tcr.tlb-pointer arm::rcontext)1825 (l wz dest arm::INTERRUPT-LEVEL-BINDING-INDEX temp))1845 (ldr temp (:@ rcontext (:$ arm::tcr.tlb-pointer))) 1846 (ldr dest (:@ temp (:$ arm::INTERRUPT-LEVEL-BINDING-INDEX)))) 1826 1847 1827 1848 … … 1887 1908 (define-arm-vinsn (discard-temp-frame :tsp :pop :discard) (() 1888 1909 ()) 1889 (l wz arm::tsp 0 arm::tsp))1910 (ldr arm::tsp (:@ arm::tsp (:$ 0)))) 1890 1911 1891 1912 … … 1897 1918 (mov header (:$ (:apply ash (:apply + 1 (:apply logandc2 (:apply + 4 1 n-c-args) 1)) arm::num-subtag-bits))) 1898 1919 (mov size (:lsr header (:$ (- arm::num-subtag-bits arm::word-shift)))) 1899 (orr header (:$ arm::subtag-u32-vector))1920 (orr header header (:$ arm::subtag-u32-vector)) 1900 1921 (mov prevsp sp) 1901 1922 (add size size (:$ arm::node-size)) … … 1936 1957 (str argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift)))))) 1937 1958 1959 #+notyet 1938 1960 (define-arm-vinsn set-single-c-arg (() 1939 1961 ((argval :single-float) … … 1941 1963 (fsts argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift)))))) 1942 1964 1965 #+notyet 1943 1966 (define-arm-vinsn set-double-c-arg (() 1944 1967 ((argval :double-float) … … 1957 1980 (add dest dest (:$ arm::t-offset))) 1958 1981 1959 (define-arm-vinsn set-eq-bit (((dest :crf)) 1960 ()) 1961 (creqv (:apply + arm::arm-eq-bit dest) 1962 (:apply + arm::arm-eq-bit dest) 1963 (:apply + arm::arm-eq-bit dest))) 1982 1964 1983 1965 1984 (define-arm-vinsn (ref-constant :constant-ref) (((dest :lisp)) … … 1969 1988 (define-arm-vinsn ref-indexed-constant (((dest :lisp)) 1970 1989 ((idxreg :s32))) 1971 (l wzx dest arm::fn idxreg))1990 (ldr dest (:@ arm::fn idxreg))) 1972 1991 1973 1992 1974 1993 (define-arm-vinsn cons (((dest :lisp)) 1975 1994 ((newcar :lisp) 1976 (newcdr :lisp))) 1977 (la arm::allocptr (- arm::fulltag-cons arm::cons.size) arm::allocptr) 1978 (twllt arm::allocptr arm::allocbase) 1979 (stw newcdr arm::cons.cdr arm::allocptr) 1980 (stw newcar arm::cons.car arm::allocptr) 1981 (mr dest arm::allocptr) 1982 (clrrwi arm::allocptr arm::allocptr arm::ntagbits)) 1995 (newcdr :lisp)) 1996 ((allocbase :imm))) 1997 (sub allocptr allocptr (:$ (- arm::cons.size arm::fulltag-cons))) 1998 (ldr allocbase (:@ rcontext (:$ arm::tcr.save-allocbase))) 1999 (cmp allocptr allocbase) 2000 (uuo-alloc-trap (:? lo)) 2001 (str newcdr (:@ allocptr (:$ arm::cons.cdr))) 2002 (str newcar (:@ allocptr (:$ arm::cons.car))) 2003 (mov dest allocptr) 2004 (bic allocptr allocptr (:$ arm::fulltagmask))) 1983 2005 1984 2006 … … 1989 2011 (nbytes :u32const)) 1990 2012 ((immtemp0 :u32) 1991 (nodetemp :lisp) 1992 (crf :crf))) 1993 (la arm::allocptr (:apply - arm::fulltag-misc 1994 (:apply logand (lognot 7) 1995 (:apply + (+ 7 4) nbytes))) 1996 arm::allocptr) 1997 (twllt arm::allocptr arm::allocbase) 1998 (stw Rheader arm::misc-header-offset arm::allocptr) 1999 (mr dest arm::allocptr) 2000 (clrrwi arm::allocptr arm::allocptr arm::ntagbits) 2013 (nodetemp :lisp))) 2014 2015 (sub allocptr allocptr (:$ (:apply logand #xff 2016 (:apply - 2017 (:apply logand (lognot 7) 2018 (:apply + (+ 7 4) nbytes)) 2019 arm::fulltag-misc)))) 2020 ((:pred > (:apply - 2021 (:apply logand (lognot 7) 2022 (:apply + (+ 7 4) nbytes)) 2023 arm::fulltag-misc) #xff) 2024 (sub allocptr allocptr (:$ (:apply logand #xff00 2025 (:apply - 2026 (:apply logand (lognot 7) 2027 (:apply + (+ 7 4) nbytes)) 2028 arm::fulltag-misc))))) 2029 (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) 2030 (cmp allocptr dest) 2031 (uuo-alloc-trap (:? lo)) 2032 (str Rheader (:@ allocptr (:$ arm::misc-header-offset))) 2033 (mov dest allocptr) 2034 (bic allocptr allocptr (:$ arm::fulltagmask)) 2001 2035 ((:not (:pred = nbytes 0)) 2002 ( li immtemp0 (:apply + arm::misc-data-offset nbytes))2036 (mov immtemp0 (:$ (:apply + arm::misc-data-offset nbytes))) 2003 2037 :loop 2004 (subi immtemp0 immtemp0 4) 2005 (cmpwi crf immtemp0 arm::misc-data-offset) 2006 (lwz nodetemp 0 arm::vsp) 2007 (la arm::vsp 4 arm::vsp) 2008 (stwx nodetemp dest immtemp0) 2009 (bne crf :loop))) 2038 (sub immtemp0 immtemp0 (:$ 4)) 2039 (cmp immtemp0 (:$ arm::misc-data-offset)) 2040 (ldr nodetemp (:@+ vsp (:$ arm::node-size))) 2041 (str nodetemp (:@ dest immtemp0)) 2042 (bne :loop))) 2010 2043 2011 2044 ;; allocate a small (phys size <= 32K bytes) misc obj of known size/subtag … … 2013 2046 ((Rheader :u32) 2014 2047 (nbytes :u32const))) 2015 (la arm::allocptr (:apply - arm::fulltag-misc 2016 (:apply logand (lognot 7) 2017 (:apply + (+ 7 4) nbytes))) 2018 arm::allocptr) 2019 (twllt arm::allocptr arm::allocbase) 2020 (stw Rheader arm::misc-header-offset arm::allocptr) 2021 (mr dest arm::allocptr) 2022 (clrrwi arm::allocptr arm::allocptr arm::ntagbits)) 2048 (sub allocptr allocptr (:$ (:apply 2049 logand #xff 2050 (:apply - (:apply logand (lognot 7) 2051 (:apply + (+ 7 4) nbytes)))))) 2052 ((:pred > (:apply - 2053 (:apply logand (lognot 7) 2054 (:apply + (+ 7 4) nbytes)) 2055 arm::fulltag-misc) #xff) 2056 (sub allocptr allocptr (:$ (:apply logand #xff00 2057 (:apply - 2058 (:apply logand (lognot 7) 2059 (:apply + (+ 7 4) nbytes)) 2060 arm::fulltag-misc))))) 2061 (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) 2062 (cmp allocptr dest) 2063 (uuo-alloc-trap (:? lo)) 2064 (str Rheader (:@ allocptr (:$ arm::misc-header-offset))) 2065 (mov dest allocptr) 2066 (bic allocptr allocptr (:$ arm::fulltagmask))) 2023 2067 2024 2068 (define-arm-vinsn (vstack-discard :vsp :pop :discard) (() 2025 2069 ((nwords :u32const))) 2026 2070 ((:not (:pred = nwords 0)) 2027 ( la arm::vsp (:apply ash nwords arm::word-shift) arm::vsp)))2071 (add vsp vsp (:$ (:apply ash nwords arm::word-shift))))) 2028 2072 2029 2073 … … 2031 2075 ((cell :lcell) 2032 2076 (top :lcell))) 2033 (l wz dest(:apply -2077 (ldr dest (:@ vsp (:$ (:apply - 2034 2078 (:apply - (:apply calc-lcell-depth top) 4) 2035 (:apply calc-lcell-offset cell)) arm::vsp))2079 (:apply calc-lcell-offset cell)))))) 2036 2080 2037 2081 (define-arm-vinsn vframe-load (((dest :lisp)) 2038 2082 ((frame-offset :u16const) 2039 2083 (cur-vsp :u16const))) 2040 (l wz dest (:apply - (:apply - cur-vsp 4) frame-offset) arm::vsp))2084 (ldr dest (:@ vsp (:$ (:apply - (:apply - cur-vsp 4) frame-offset))))) 2041 2085 2042 2086 (define-arm-vinsn lcell-store (() … … 2044 2088 (cell :lcell) 2045 2089 (top :lcell))) 2046 (st w src(:apply -2090 (str src (:@ vsp (:$ (:apply - 2047 2091 (:apply - (:apply calc-lcell-depth top) 4) 2048 (:apply calc-lcell-offset cell)) arm::vsp))2092 (:apply calc-lcell-offset cell)))))) 2049 2093 2050 2094 (define-arm-vinsn vframe-store (() … … 2052 2096 (frame-offset :u16const) 2053 2097 (cur-vsp :u16const))) 2054 (st w src (:apply - (:apply - cur-vsp 4) frame-offset) arm::vsp))2098 (str src (:@ vsp (:$ (:apply - (:apply - cur-vsp 4) frame-offset))))) 2055 2099 2056 2100 (define-arm-vinsn load-vframe-address (((dest :imm)) 2057 2101 ((offset :s16const))) 2058 ( la dest offset arm::vsp))2102 (add dest vsp (:$ offset))) 2059 2103 2060 2104 (define-arm-vinsn copy-lexpr-argument (() 2061 2105 () 2062 2106 ((temp :lisp))) 2063 (l wzx temp arm::vsp nargs)2064 (st wu temp -4 arm::vsp))2107 (ldr temp (:@ vsp nargs)) 2108 (str temp (:@! vsp (:$ (- arm::node-size))))) 2065 2109 2066 2110 ;;; Boxing/unboxing of integers. … … 2070 2114 ((val :u8)) 2071 2115 ()) 2072 (rlwinm result val arm::fixnumshift (- arm::nbits-in-word (+ 8 arm::fixnumshift)) (- arm::least-significant-bit arm::fixnumshift))) 2116 (mov result (:lsr val (:$ 24))) 2117 (mov result (:lsr val (:$ (- 24 arm::fixnumshift))))) 2073 2118 2074 2119 ;;; Treat the low 8 bits of VAL as a signed integer; set RESULT to the equivalent fixnum. … … 2076 2121 ((val :s8)) 2077 2122 ()) 2078 ( extlwi result val 8 (- arm::nbits-in-word 8))2079 ( srawi result result (- (- arm::nbits-in-word 8) arm::fixnumshift)))2123 (mov result (:lsr val (:$ 24))) 2124 (mov result (:asr val (:$ (- 24 arm::fixnumshift))))) 2080 2125 2081 2126 … … 2084 2129 ((val :u16)) 2085 2130 ()) 2086 (rlwinm result val arm::fixnumshift (- arm::nbits-in-word (+ 16 arm::fixnumshift)) (- arm::least-significant-bit arm::fixnumshift))) 2131 (mov result (:lsl val (:$ 16))) 2132 (mov result (:lsr result (:$ (- 16 arm::fixnumshift))))) 2087 2133 2088 2134 ;;; Treat the low 16 bits of VAL as a signed integer; set RESULT to the equivalent fixnum. … … 2108 2154 (mov temp (:$ arm::subtag-bignum)) 2109 2155 (orr temp temp (:$ (ash 1 arm::num-subtag-bits))) 2110 (add a rm::allocptr arm::allocptr (:$ (- arm::fulltag-misc 8)))2111 (ldr result (:@ rcontext (:$ arm::tcr.save _allocbase)))2156 (add allocptr allocptr (:$ (- arm::fulltag-misc 8))) 2157 (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase))) 2112 2158 (cmp allocptr result) 2113 (uuo-alloc-trap -one(:? lo))2159 (uuo-alloc-trap (:? lo)) 2114 2160 (str temp (:@ allocptr (:$ arm::misc-header-offset))) 2115 2161 (mov result allocptr) … … 2122 2168 (define-arm-vinsn u32->integer (((result :lisp)) 2123 2169 ((src :u32)) 2124 ((crf (:crf 0)) ; a casualty 2125 (temp :s32) 2170 ((temp :s32) 2126 2171 (size :u32))) 2127 (clrrwi. temp src (- arm::least-significant-bit arm::nfixnumtagbits)) 2128 (slwi result src arm::fixnumshift) 2129 (beq+ crf :done) 2130 (cmpwi src 0) 2131 (li temp arm::one-digit-bignum-header) 2132 (li size (- 8 arm::fulltag-misc)) 2133 (bgt :common) 2134 (li temp arm::two-digit-bignum-header) 2135 (li size (- 16 arm::fulltag-misc)) 2136 :common 2137 (sub arm::allocptr arm::allocptr size) 2138 (twllt arm::allocptr arm::allocbase) 2139 (stw temp arm::misc-header-offset arm::allocptr) 2140 (mr result arm::allocptr) 2141 (clrrwi arm::allocptr arm::allocptr arm::ntagbits) 2142 (stw src arm::misc-data-offset result) 2172 (tst src (:$ #xe0000000)) 2173 (moveq result (:lsr src (:$ arm::fixnumshift))) 2174 (beq :done) 2175 (cmp src (:$ 0)) 2176 (mov temp (:$ arm::subtag-bignum)) 2177 (movgt size (:$ (- (* 2 arm::dnode-size) arm::fulltag-misc))) 2178 (orrgt temp temp (:$ (ash 2 arm::num-subtag-bits))) 2179 (movlt size (:$ (- (* 1 arm::dnode-size) arm::fulltag-misc))) 2180 (orrlt temp temp (:$ (ash 1 arm::num-subtag-bits))) 2181 (sub allocptr allocptr size) 2182 (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase))) 2183 (cmp allocptr result) 2184 (uuo-alloc-trap (:? lo)) 2185 (str temp (:@ allocptr (:$ arm::misc-header-offset))) 2186 (mov result allocptr) 2187 (bic allocptr allocptr (:$ arm::fulltagmask)) 2188 (str src (:@ result (:$ arm::misc-data-offset))) 2143 2189 :done) 2144 2190 2145 2191 (define-arm-vinsn u16->u32 (((dest :u32)) 2146 2192 ((src :u16))) 2147 (clrlwi dest src 16)) 2193 (mov dest (:$ #xff)) 2194 (orr dest dest (:$ #xff00)) 2195 (and dest dest src)) 2148 2196 2149 2197 (define-arm-vinsn u8->u32 (((dest :u32)) 2150 2198 ((src :u8))) 2151 ( clrlwi dest src 24))2199 (and dest src (:$ #xff))) 2152 2200 2153 2201 2154 2202 (define-arm-vinsn s16->s32 (((dest :s32)) 2155 2203 ((src :s16))) 2156 (extsh dest src)) 2204 (mov dest (:lsl src (:$ 16))) 2205 (mov dest (:asr src (:$ 16)))) 2157 2206 2158 2207 (define-arm-vinsn s8->s32 (((dest :s32)) 2159 2208 ((src :s8))) 2160 (extsb dest src)) 2209 (mov dest (:lsl src (:$ 24))) 2210 (mov dest (:asr src (:$ 24)))) 2161 2211 2162 2212 … … 2167 2217 (define-arm-vinsn double->heap (((result :lisp)) ; tagged as a double-float 2168 2218 ((fpreg :double-float)) 2169 ((header-temp :u32))) 2170 (li header-temp (arch::make-vheader arm::double-float.element-count arm::subtag-double-float)) 2171 (la arm::allocptr (- arm::fulltag-misc arm::double-float.size) arm::allocptr) 2172 (twllt arm::allocptr arm::allocbase) 2173 (stw header-temp arm::misc-header-offset arm::allocptr) 2174 (mr result arm::allocptr) 2175 (clrrwi arm::allocptr arm::allocptr arm::ntagbits) 2176 (stfd fpreg arm::double-float.value result) ) 2219 ((header-temp (:u32 #.arm::imm0)) 2220 (high (:u32 #.arm::imm1)))) 2221 (mov header-temp (:$ arm::subtag-double-float)) 2222 (orr header-temp header-temp (:$ (ash arm::double-float.element-count arm::num-subtag-bits))) 2223 (sub allocptr allocptr (:$ (- arm::double-float.size arm::fulltag-misc))) 2224 (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase))) 2225 (cmp allocptr result) 2226 (uuo-alloc-trap (:? lo)) 2227 (str header-temp (:@ allocptr (:$ arm::misc-header-offset))) 2228 (mov result allocptr) 2229 (bic allocptr allocptr (:$ arm::fulltagmask)) 2230 (fmrrd header-temp high fpreg) 2231 (strd header-temp (:@ result (:$ arm::double-float.value)))) 2177 2232 2178 2233 … … 2184 2239 ((fpreg :single-float)) 2185 2240 ((header-temp :u32))) 2186 (li header-temp (arch::make-vheader arm::single-float.element-count arm::subtag-single-float)) 2187 (la arm::allocptr (- arm::fulltag-misc arm::single-float.size) arm::allocptr) 2188 (twllt arm::allocptr arm::allocbase) 2189 (stw header-temp arm::misc-header-offset arm::allocptr) 2190 (mr result arm::allocptr) 2191 (clrrwi arm::allocptr arm::allocptr arm::ntagbits) 2192 (stfs fpreg arm::single-float.value result)) 2241 (mov header-temp (:$ arm::subtag-single-float)) 2242 (orr header-temp header-temp (:$ (ash arm::single-float.element-count arm::num-subtag-bits))) 2243 (sub allocptr allocptr (:$ (- arm::single-float.size arm::fulltag-misc))) 2244 (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase))) 2245 (cmp allocptr result) 2246 (uuo-alloc-trap (:? lo)) 2247 (str header-temp (:@ allocptr (:$ arm::misc-header-offset))) 2248 (mov result allocptr) 2249 (bic allocptr allocptr (:$ arm::fulltagmask)) 2250 (fmrs header-temp fpreg) 2251 (str header-temp (:@ result (:$ arm::single-float.value)))) 2252 2193 2253 2194 2254 … … 2197 2257 ((dest :lisp) 2198 2258 (source :double-float)) 2199 ()) 2200 (stfd source arm::double-float.value dest)) 2259 ((low (:u32 #.arm::imm0)) 2260 (high (:u32 #.arm::imm1)))) 2261 (fmrrd low high source) 2262 (str low (:@ dest (:$ arm::double-float.value)))) 2201 2263 2202 2264 (define-arm-vinsn get-double (((target :double-float)) 2203 2265 ((source :lisp)) 2204 ()) 2205 (lfd target arm::double-float.value source)) 2266 ((low (:u32 #.arm::imm0)) 2267 (high (:u32 #.arm::imm1)))) 2268 (ldrd low (:@ source (:$ arm::double-float.value))) 2269 (fmdrr target low high)) 2206 2270 2207 2271 ;;; Extract a double-float value, typechecking in the process. … … 2211 2275 (define-arm-vinsn get-double? (((target :double-float)) 2212 2276 ((source :lisp)) 2213 ((tag :u8))) 2214 (and tag source (:$ arm::tagmask)) 2215 (cmp tag (:$ arm::tag-misc)) 2216 (ldrbeq tag (:@ source (:$ arm::misc-subtag-offset))) 2217 (cmp tag (:$ arm::subtag-double-float)) 2277 ((low (:u32 #.arm::imm0)) 2278 (high (:u32 #.arm::imm1)))) 2279 (and low source (:$ arm::tagmask)) 2280 (cmp low (:$ arm::tag-misc)) 2281 (ldrbeq low (:@ source (:$ arm::misc-subtag-offset))) 2282 (cmp imm0 (:$ arm::subtag-double-float)) 2218 2283 (uuo-error-reg-not-xtype (:? ne) source (:$ arm::subtag-double-float)) 2219 (ldrd imm0 imm1(:@ source (:$ arm::double-float.value)))2220 (fm rrdtarget imm0 imm1))2284 (ldrd imm0 (:@ source (:$ arm::double-float.value))) 2285 (fmdrr target imm0 imm1)) 2221 2286 2222 2287 2223 2288 (define-arm-vinsn double-to-single (((result :single-float)) 2224 2289 ((arg :double-float))) 2225 (f rspresult arg))2290 (fcvtsd result arg)) 2226 2291 2227 2292 (define-arm-vinsn store-single (() 2228 2293 ((dest :lisp) 2229 2294 (source :single-float)) 2230 ()) 2231 (stfs source arm::single-float.value dest)) 2295 ((temp :u32))) 2296 (fmrs temp source) 2297 (str temp (:@ dest (:$ arm::single-float.value)))) 2232 2298 2233 2299 (define-arm-vinsn get-single (((target :single-float)) 2234 2300 ((source :lisp)) 2235 ()) 2236 (lfs target arm::single-float.value source)) 2301 ((temp :u32))) 2302 (ldr temp (:@ source (:$ arm::single-float.value))) 2303 (fmsr target temp)) 2237 2304 2238 2305 ;;; ... of characters ... … … 2253 2320 ((src :imm)) 2254 2321 ((temp :u32) 2255 (crf0 (:crf 0)))) 2256 (srwi temp src (+ arm::fixnumshift 1)) 2257 (cmplwi temp (ash #xffff -1)) 2258 (srwi temp src (+ arm::fixnumshift 11)) 2322 (temp2 :u32))) 2323 (mov temp2 (:$ #x7f00)) 2324 (mov temp (:lsr src (:$ (+ arm::fixnumshift 1)))) 2325 (orr temp2 temp2 (:$ #xff)) 2326 (cmp temp temp2) 2327 (mov temp (:lsr src (:$ (+ arm::fixnumshift 11)))) 2259 2328 (beq :bad) 2260 (cmpwi temp 27) 2261 (slwi dest src (- arm::charcode-shift arm::fixnumshift)) 2262 (bne+ :ok) 2329 (cmp temp (:$ 27)) 2330 (mov dest (:lsr src (:$ (- arm::charcode-shift arm::fixnumshift)))) 2263 2331 :bad 2264 (li dest (:apply target-nil-value)) 2265 (b :done) 2266 :ok 2267 (addi dest dest arm::subtag-character) 2268 :done) 2332 (moveq dest (:$ arm::nil-value)) 2333 (addne dest dest (:$ arm::subtag-character))) 2269 2334 2270 2335 ;;; src is known to be a code for which CODE-CHAR returns non-nil. … … 2298 2363 ((address :address)) 2299 2364 ((header :u32))) 2300 (li header (logior (ash arm::macptr.element-count arm::num-subtag-bits) arm::subtag-macptr)) 2301 (la arm::allocptr (- arm::fulltag-misc arm::macptr.size) arm::allocptr) 2302 (twllt arm::allocptr arm::allocbase) 2303 (stw header arm::misc-header-offset arm::allocptr) 2304 (mr dest arm::allocptr) 2305 (clrrwi arm::allocptr arm::allocptr arm::ntagbits) 2365 (mov header (:$ arm::subtag-macptr)) 2366 (orr header header (:$ (ash arm::macptr.element-count arm::num-subtag-bits))) 2367 (sub allocptr allocptr (:$ (- arm::macptr.size arm::fulltag-misc))) 2368 (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) 2369 (cmp allocptr dest) 2370 (uuo-alloc-trap (:? lo)) 2371 (str header (:@ allocptr (:$ arm::misc-header-offset))) 2372 (mov dest allocptr) 2373 (bic allocptr allocptr (:$ arm::fulltagmask)) 2306 2374 ;; It's not necessary to zero out the domain/type fields, since newly 2307 2375 ;; heap-allocated memory's guaranteed to be 0-filled. 2308 (st w address arm::macptr.address dest))2376 (str address (:@ dest (:$ arm::macptr.address)))) 2309 2377 2310 2378 (define-arm-vinsn macptr->stack (((dest :lisp)) 2311 2379 ((address :address)) 2312 2380 ((header :u32))) 2313 ( li header arm::macptr-header)2314 ( stwu arm::tsp (- (+ 8 arm::macptr.size)) arm::tsp)2315 (st w arm::tsp 4 arm::tsp)2316 ( stw header (+ 8 arm::fulltag-misc arm::macptr.header) arm::tsp)2317 (st w address (+ 8 arm::fulltag-misc arm::macptr.address) arm::tsp)2318 ;; It -is- necessary to zero out the domain/type fields here, since2319 ;; stack-allocated memory isn't guaranteed to be 0-filled.2320 ( stfd arm::fp-zero (+ 8 arm::fulltag-misc arm::macptr.domain) arm::tsp)2321 (la dest (+ 8 arm::fulltag-misc) arm::tsp)) 2381 (mov header (:$ arm::subtag-macptr)) 2382 (orr header header (:$ (ash arm::macptr.element-count arm::num-subtag-bits))) 2383 (str header (:@! sp (:$ (- arm::macptr.size)))) 2384 (mov header (:$ 0)) 2385 (str header (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.domain)))) 2386 (str header (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.type)))) 2387 (str address (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.address)))) 2388 (add dest sp (:$ arm::fulltag-misc))) 2389 2322 2390 2323 2391 … … 2329 2397 (define-arm-vinsn adjust-vsp (() 2330 2398 ((amount :s16const))) 2331 ( la arm::vsp amount arm::vsp))2399 (add vsp vsp (:$ amount))) 2332 2400 2333 2401 (define-arm-vinsn adjust-sp (() 2334 2402 ((amount :s16const))) 2335 ( la arm::sp amount arm::sp))2403 (add sp sp (:$ amount))) 2336 2404 2337 2405 ;; Arithmetic on fixnums & unboxed numbers … … 2353 2421 ((unboxed :s32) 2354 2422 (header :u32))) 2355 (nego. dest src) 2356 (bns+ :done) 2357 (mtxer arm::rzero) 2358 (srawi unboxed dest arm::fixnumshift) 2359 (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 arm::fixnumshift)))) 2360 (li header arm::one-digit-bignum-header) 2361 (la arm::allocptr (- arm::fulltag-misc 8) arm::allocptr) 2362 (twllt arm::allocptr arm::allocbase) 2363 (stw header arm::misc-header-offset arm::allocptr) 2364 (mr dest arm::allocptr) 2365 (clrrwi arm::allocptr arm::allocptr arm::ntagbits) 2366 (stw unboxed arm::misc-data-offset dest) 2423 (rsbs dest src (:$ 0)) 2424 (bvc :done) 2425 (mov unboxed (:asr dest (:$ arm::fixnumshift))) 2426 (eor unboxed unboxed (:$ #xc0000000)) 2427 (mov header (:$ arm::subtag-bignum)) 2428 (orr header header (:$ (ash 1 arm::num-subtag-bits))) 2429 (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc))) 2430 (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) 2431 (cmp allocptr dest) 2432 (uuo-alloc-trap (:? lo)) 2433 (str header (:@ allocptr (:$ arm::misc-header-offset))) 2434 (mov dest allocptr) 2435 (bic allocptr allocptr (:$ arm::fulltagmask)) 2436 (str unboxed (:@ dest (:$ arm::misc-data-offset))) 2367 2437 :done) 2368 2438 … … 2370 2440 ((src :imm)) 2371 2441 ) 2372 (nego. arm::arg_z src) 2373 (bsola- .SPfix-overflow) 2374 :done) 2442 (rsbs arm::arg_z src (:$ 0)) 2443 (blvs .SPfix-overflow)) 2375 2444 2376 2445 … … 2379 2448 ((src :imm))) 2380 2449 2381 ( neg dest src))2450 (rsb dest src (:$ 0))) 2382 2451 2383 2452 2384 (define-arm-vinsn logior- high(((dest :imm))2453 (define-arm-vinsn logior-immediate (((dest :imm)) 2385 2454 ((src :imm) 2386 (high :u16const))) 2387 (oris dest src high)) 2388 2389 (define-arm-vinsn logior-low (((dest :imm)) 2390 ((src :imm) 2391 (low :u16const))) 2392 (ori dest src low)) 2455 (imm :u32const))) 2456 (orr dest src (:$ imm))) 2457 2458 2393 2459 2394 2460 … … 2398 2464 (y :imm)) 2399 2465 ()) 2400 (or dest x y))2401 2402 (define-arm-vinsn logand- high(((dest :imm))2466 (orr dest x y)) 2467 2468 (define-arm-vinsn logand-immediate (((dest :imm)) 2403 2469 ((src :imm) 2404 (high :u16const)) 2405 ((crf0 (:crf 0)))) 2406 (andis. dest src high)) 2407 2408 (define-arm-vinsn logand-low (((dest :imm)) 2409 ((src :imm) 2410 (low :u16const)) 2411 ((crf0 (:crf 0)))) 2412 (andi. dest src low)) 2470 (imm :u32const))) 2471 (and dest src (:$ imm))) 2413 2472 2414 2473 … … 2419 2478 (and dest x y)) 2420 2479 2421 (define-arm-vinsn clear-left (((dest :imm)) 2422 ((src :imm) 2423 (nbits :s8const))) 2424 (rlwinm dest src 0 (:apply 1+ nbits) 31)) 2425 2426 (define-arm-vinsn clear-right (((dest :imm)) 2427 ((src :imm) 2428 (nbits :s8const))) 2429 (rlwinm dest src 0 0 (:apply - 31 nbits))) 2480 (define-arm-vinsn logxor-immediate (((dest :imm)) 2481 ((src :imm) 2482 (imm :u32const))) 2483 (eor dest src (:$ imm))) 2484 2430 2485 2431 2486 2432 (define-arm-vinsn logxor-high (((dest :imm))2433 ((src :imm)2434 (high :u16const)))2435 (xoris dest src high))2436 2437 (define-arm-vinsn logxor-low (((dest :imm))2438 ((src :imm)2439 (low :u16const)))2440 (xori dest src low))2441 2442 2443 2487 2444 2488 (define-arm-vinsn %logxor2 (((dest :imm)) … … 2446 2490 (y :imm)) 2447 2491 ()) 2448 (xor dest x y)) 2449 2492 (eor dest x y)) 2493 2494 ;;; ARM register shifts shift by the low byte of RS. 2450 2495 (define-arm-vinsn %ilsl (((dest :imm)) 2451 2496 ((count :imm) 2452 2497 (src :imm)) 2453 ((temp :u32) 2454 (crx :crf))) 2455 (cmpwi crx count (ash 31 arm::fixnumshift)) 2456 (srwi temp count arm::fixnumshift) 2457 (slw dest src temp) 2458 (ble+ crx :foo) 2459 (li dest 0) 2460 :foo) 2461 2498 ((temp :u32))) 2499 (mov temp (:asr count (:$ arm::fixnumshift))) 2500 (mov dest (:lsl src temp))) 2501 2502 ;;; Shift by a constant = -> shift by 32. Don't do that. 2462 2503 (define-arm-vinsn %ilsl-c (((dest :imm)) 2463 2504 ((count :u8const) 2464 2505 (src :imm))) 2465 ; Hard to use armmacroinstructions that expand into expressions involving variables. 2466 (rlwinm dest src count 0 (:apply - arm::least-significant-bit count))) 2506 ((:pred = count 0) 2507 (mov dest src)) 2508 ((:not (:pred = count 0)) 2509 (mov dest (:lsl src (:$ (:apply logand count 31)))))) 2467 2510 2468 2511 … … 2470 2513 ((count :u8const) 2471 2514 (src :imm)) 2472 ( temp :s32))2515 ((temp :s32))) 2473 2516 (mov temp (:lsr src (:$ count))) 2474 (bic test src (:$fixnummask)))2517 (bic dest temp (:$ arm::fixnummask))) 2475 2518 2476 2519 … … 2479 2522 (src :imm)) 2480 2523 ((temp :s32))) 2481 (cmp count (:$ (ash 31 arm::fixnumshift)))2482 2524 (mov temp (:asr count (:$ arm::fixnumshift))) 2483 2525 (mov temp (:asr src temp)) 2484 (movgt temp (:asr src (:$ 31))) 2485 (bic test temp (:$ arm::fixnummask))) 2526 (bic dest temp (:$ arm::fixnummask))) 2486 2527 2487 2528 (define-arm-vinsn %iasr-c (((dest :imm)) … … 2489 2530 (src :imm)) 2490 2531 ((temp :s32))) 2491 (mov temp (:asr src (:$ count))) 2492 (bic dest src (:$ arm::fixnummask))) 2532 ((:pred = count 0) 2533 (mov dest src)) 2534 ((:not (:pred = count 0)) 2535 (mov temp (:asr src (:$ count))) 2536 (bic dest src (:$ arm::fixnummask)))) 2493 2537 2494 2538 (define-arm-vinsn %ilsr (((dest :imm)) 2495 2539 ((count :imm) 2496 2540 (src :imm)) 2497 ((temp :s32) 2498 (crx :crf))) 2499 (cmpwi crx count (ash 31 arm::fixnumshift)) 2500 (srwi temp count arm::fixnumshift) 2501 (srw temp src temp) 2502 (clrrwi dest temp arm::fixnumshift) 2503 (ble+ crx :foo) 2504 (li dest 0) 2505 :foo 2506 ) 2507 2508 #+maybe 2541 ((temp :s32))) 2542 (mov temp (:asr count (:$ arm::fixnumshift))) 2543 (mov temp (:lsr src temp)) 2544 (bic dest temp (:$ arm::fixnummask))) 2545 2546 2509 2547 (define-arm-vinsn %ilsr-c (((dest :imm)) 2510 2548 ((count :u8const) 2511 2549 (src :imm)) 2512 2550 ((temp :s32))) 2513 (rlwinm temp src (:apply - 32 count) count 31) 2514 (clrrwi dest temp arm::fixnumshift)) 2551 ((:pred = count 0) 2552 (mov dest src)) 2553 ((:not (:pred = count 0)) 2554 (mov temp (:lsr src (:$ count))) 2555 (bic dest temp (:$ arm::fixnummask)))) 2515 2556 2516 2557 (define-arm-vinsn natural-shift-left (((dest :u32)) 2517 2558 ((src :u32) 2518 2559 (count :u8const))) 2519 (rlwinm dest src count 0 (:apply - 31 count))) 2560 ((:pred = count 0) 2561 (mov dest src)) 2562 ((:not (:pred = count 0)) 2563 (mov dest (:lsl src (:$ count))))) 2520 2564 2521 2565 (define-arm-vinsn natural-shift-right (((dest :u32)) 2522 2566 ((src :u32) 2523 2567 (count :u8const))) 2524 (rlwinm dest src (:apply - 32 count) count 31)) 2568 ((:pred = count 0) 2569 (mov dest src)) 2570 ((:not (:pred = count 0)) 2571 (mov dest (:lsr src (:$ count))))) 2525 2572 2526 2573 … … 2530 2577 (type-error :u8const)) 2531 2578 ((tag :u8) 2532 (flags :u32) 2533 (crf :crf))) 2534 (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) 2535 (cmpwi crf tag arm::tag-misc) 2536 (bne crf :bad) 2537 (lbz tag arm::misc-subtag-offset object) 2538 (cmpwi crf tag arm::subtag-arrayH) 2539 (bne crf :bad) 2540 (lwz tag arm::arrayH.rank object) 2541 (cmpwi crf tag (ash 2 arm::fixnumshift)) 2542 (lis tag (:apply ldb (byte 16 16) (:apply ash expected-flags arm::fixnumshift))) 2543 2544 (lwz flags arm::arrayH.flags object) 2545 (ori tag tag (:apply ldb (byte 16 0) (:apply ash expected-flags arm::fixnumshift))) 2546 (bne crf :bad) 2547 (cmpw crf tag flags) 2548 (beq crf :good) 2549 :bad 2550 (uuo_interr type-error object) 2551 :good) 2579 (flags :u32))) 2580 (and tag object (:$ arm::tagmask)) 2581 (cmp tag (:$ arm::tag-misc)) 2582 (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) 2583 (cmp tag (:$ arm::subtag-arrayH)) 2584 (bne :bad-if-ne) 2585 (ldr tag (:@ object (:$ arm::arrayH.rank))) 2586 (cmp tag (:$ (ash 2 arm::fixnumshift))) 2587 (bne :bad-if-ne) 2588 (mov tag (:$ (:apply ash (:apply logand expected-flags #xff00) arm::fixnumshift))) 2589 (orr tag tag (:$ (:apply ash (:apply logand expected-flags #x00ff) arm::fixnumshift))) 2590 (ldr flags (:@ object (:$ arm::arrayH.flags))) 2591 (cmp tag flags) 2592 :bad-if-ne 2593 (uuo-error-reg-not-xtype (:? ne) object (:$ type-error))) 2552 2594 2553 2595 (define-arm-vinsn trap-unless-simple-array-3 (() 2554 2596 ((object :lisp) 2555 (expected-flags :u 32const)2597 (expected-flags :u16const) 2556 2598 (type-error :u8const)) 2557 2599 ((tag :u8) 2558 (flags :u32) 2559 (crf :crf))) 2560 (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) 2561 (cmpwi crf tag arm::tag-misc) 2562 (bne crf :bad) 2563 (lbz tag arm::misc-subtag-offset object) 2564 (cmpwi crf tag arm::subtag-arrayH) 2565 (bne crf :bad) 2566 (lwz tag arm::arrayH.rank object) 2567 (cmpwi crf tag (ash 3 arm::fixnumshift)) 2568 (lis tag (:apply ldb (byte 16 16) (:apply ash expected-flags arm::fixnumshift))) 2569 2570 (lwz flags arm::arrayH.flags object) 2571 (ori tag tag (:apply ldb (byte 16 0) (:apply ash expected-flags arm::fixnumshift))) 2572 (bne crf :bad) 2573 (cmpw crf tag flags) 2574 (beq crf :good) 2575 :bad 2576 (uuo_interr type-error object) 2577 :good) 2600 (flags :u32))) 2601 (and tag object (:$ arm::tagmask)) 2602 (cmp tag (:$ arm::tag-misc)) 2603 (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) 2604 (cmp tag (:$ arm::subtag-arrayH)) 2605 (bne :bad-if-ne) 2606 (ldr tag (:@ object (:$ arm::arrayH.rank))) 2607 (cmp tag (:$ (ash 3 arm::fixnumshift))) 2608 (bne :bad-if-ne) 2609 (mov tag (:$ (:apply ash (:apply logand expected-flags #xff00) arm::fixnumshift))) 2610 (orr tag tag (:$ (:apply ash (:apply logand expected-flags #x00ff) arm::fixnumshift))) 2611 (ldr flags (:@ object (:$ arm::arrayH.flags))) 2612 (cmp tag flags) 2613 :bad-if-ne 2614 (uuo-error-reg-not-xtype (:? ne) object (:$ type-error))) 2578 2615 2579 2616 … … 2582 2619 (define-arm-vinsn sign-extend-halfword (((dest :imm)) 2583 2620 ((src :imm))) 2584 (slwi dest src (- 16 arm::fixnumshift)) 2585 (srawi dest dest (- 16 arm::fixnumshift))) 2586 2587 (define-arm-vinsn s32-highword (((dest :imm)) 2588 ((src :s32)) 2589 ((temp :s32))) 2590 (srawi temp src 16) 2591 (slwi dest temp arm::fixnumshift)) 2621 (mov dest (:lsl src (:$ (- 16 arm::fixnumshift)))) 2622 (mov dest (:asr dest (:$ (- 16 arm::fixnumshift))))) 2623 2592 2624 2593 2625 … … 2602 2634 ((x :imm) 2603 2635 (y :imm)) 2604 ( (cr0 (:crf 0))))2605 (add o.arm::arg_z x y)2606 (b sola-.SPfix-overflow))2636 ()) 2637 (adds arm::arg_z x y) 2638 (blvs .SPfix-overflow)) 2607 2639 2608 2640 (define-arm-vinsn fixnum-add-overflow-inline (((dest :lisp)) 2609 2641 ((x :imm) 2610 2642 (y :imm)) 2611 ((cr0 (:crf 0)) 2612 (unboxed :s32) 2643 ((unboxed :s32) 2613 2644 (header :u32))) 2614 (addo. dest x y) 2615 (bns+ cr0 :done) 2616 (mtxer arm::rzero) 2617 (srawi unboxed dest arm::fixnumshift) 2618 (li header arm::one-digit-bignum-header) 2619 (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 arm::fixnumshift)))) 2620 (la arm::allocptr (- arm::fulltag-misc 8) arm::allocptr) 2621 (twllt arm::allocptr arm::allocbase) 2622 (stw header arm::misc-header-offset arm::allocptr) 2623 (mr dest arm::allocptr) 2624 (clrrwi arm::allocptr arm::allocptr arm::ntagbits) 2625 (stw unboxed arm::misc-data-offset dest) 2645 (adds dest x y) 2646 (bvc :done) 2647 (mov unboxed (:asr dest (:$ arm::fixnumshift))) 2648 (mov header (:$ arm::subtag-bignum)) 2649 (orr header header (:$ (ash 1 arm::num-subtag-bits))) 2650 (eor unboxed unboxed (:$ #xc0000000)) 2651 (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc))) 2652 (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) 2653 (cmp allocptr dest) 2654 (uuo-alloc-trap (:? lo)) 2655 (str header (:@ allocptr (:$ arm::misc-header-offset))) 2656 (mov dest allocptr) 2657 (bic allocptr allocptr (:$ arm::fulltagmask)) 2658 (str unboxed (:@ dest (:$ arm::misc-data-offset))) 2626 2659 :done) 2627 2660 … … 2630 2663 (y :imm) 2631 2664 (target :label)) 2632 ((cr0 (:crf 0)) 2633 (unboxed :s32) 2665 ((unboxed :s32) 2634 2666 (header :u32))) 2635 (addo. dest x y) 2636 (bns+ cr0 target) 2637 (mtxer arm::rzero) 2638 (srawi unboxed dest arm::fixnumshift) 2639 (li header arm::one-digit-bignum-header) 2640 (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 arm::fixnumshift)))) 2641 (la arm::allocptr (- arm::fulltag-misc 8) arm::allocptr) 2642 (twllt arm::allocptr arm::allocbase) 2643 (stw header arm::misc-header-offset arm::allocptr) 2644 (mr dest arm::allocptr) 2645 (clrrwi arm::allocptr arm::allocptr arm::ntagbits) 2646 (stw unboxed arm::misc-data-offset dest) 2667 (adds dest x y) 2668 (bvc target) 2669 (mov unboxed (:asr dest (:$ arm::fixnumshift))) 2670 (mov header (:$ arm::subtag-bignum)) 2671 (orr header header (:$ (ash 1 arm::num-subtag-bits))) 2672 (eor unboxed unboxed (:$ #xc0000000)) 2673 (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc))) 2674 (ldr dest (:@ rcontext (:$ arm::tcr.save-allocptr))) 2675 (cmp allocptr dest) 2676 (uuo-alloc-trap (:? lo)) 2677 (str header (:@ allocptr (:$ arm::misc-header-offset))) 2678 (mov dest allocptr) 2679 (bic allocptr allocptr (:$ arm::fulltagmask)) 2680 (str unboxed (:@ dest (:$ arm::misc-data-offset))) 2647 2681 (b target)) 2648 2682 … … 2654 2688 ((x t) 2655 2689 (y t))) 2656 (sub f dest y x))2690 (sub dest x y)) 2657 2691 2658 2692 (define-arm-vinsn fixnum-sub-from-constant (((dest :imm)) 2659 2693 ((x :s16const) 2660 2694 (y :imm))) 2661 ( subfic dest y (:apply ash x arm::fixnumshift)))2695 (rsb dest y (:$ (:apply ash x arm::fixnumshift)))) 2662 2696 2663 2697 … … 2667 2701 ((x :imm) 2668 2702 (y :imm))) 2669 (sub o.arm::arg_z x y)2670 (b sola-.SPfix-overflow))2703 (subs arm::arg_z x y) 2704 (blvs .SPfix-overflow)) 2671 2705 2672 2706 (define-arm-vinsn fixnum-sub-overflow-inline (((dest :lisp)) … … 2676 2710 (unboxed :s32) 2677 2711 (header :u32))) 2678 (subo. dest x y) 2679 (bns+ cr0 :done) 2680 (mtxer arm::rzero) 2681 (srawi unboxed dest arm::fixnumshift) 2682 (li header arm::one-digit-bignum-header) 2683 (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 arm::fixnumshift)))) 2684 (la arm::allocptr (- arm::fulltag-misc 8) arm::allocptr) 2685 (twllt arm::allocptr arm::allocbase) 2686 (stw header arm::misc-header-offset arm::allocptr) 2687 (mr dest arm::allocptr) 2688 (clrrwi arm::allocptr arm::allocptr arm::ntagbits) 2689 (stw unboxed arm::misc-data-offset dest) 2712 (subs dest x y) 2713 (bvc :done) 2714 (mov unboxed (:asr dest (:$ arm::fixnumshift))) 2715 (mov header (:$ arm::subtag-bignum)) 2716 (orr header header (:$ (ash 1 arm::num-subtag-bits))) 2717 (eor unboxed unboxed (:$ #xc0000000)) 2718 (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc))) 2719 (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) 2720 (cmp allocptr dest) 2721 (uuo-alloc-trap (:? lo)) 2722 (str header (:@ allocptr (:$ arm::misc-header-offset))) 2723 (mov dest allocptr) 2724 (bic allocptr allocptr (:$ arm::fulltagmask)) 2725 (str unboxed (:@ dest (:$ arm::misc-data-offset))) 2690 2726 :done) 2691 2727 … … 2694 2730 (y :imm) 2695 2731 (target :label)) 2696 ((cr0 (:crf 0)) 2697 (unboxed :s32) 2732 ((unboxed :s32) 2698 2733 (header :u32))) 2699 (subo. dest x y) 2700 (bns+ cr0 target) 2701 (mtxer arm::rzero) 2702 (srawi unboxed dest arm::fixnumshift) 2703 (li header arm::one-digit-bignum-header) 2704 (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 arm::fixnumshift)))) 2705 (la arm::allocptr (- arm::fulltag-misc 8) arm::allocptr) 2706 (twllt arm::allocptr arm::allocbase) 2707 (stw header arm::misc-header-offset arm::allocptr) 2708 (mr dest arm::allocptr) 2709 (clrrwi arm::allocptr arm::allocptr arm::ntagbits) 2710 (stw unboxed arm::misc-data-offset dest) 2734 (subs dest x y) 2735 (bvc target) 2736 (mov unboxed (:asr dest (:$ arm::fixnumshift0))) 2737 (mov header (:$ arm::subtag-bignum)) 2738 (orr header header (:$ (ash 1 arm::num-subtag-bits))) 2739 (eor unboxed unboxed (:$ #xc0000000)) 2740 (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc))) 2741 (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) 2742 (cmp allocptr dest) 2743 (uuo-alloc-trap (:? lo)) 2744 (str header (:@ allocptr (:$ arm::misc-header-offset))) 2745 (mov dest allocptr) 2746 (bic allocptr allocptr (:$ arm::fulltagmask)) 2747 (str unboxed (:@ dest (:$ arm::misc-data-offset))) 2711 2748 (b target)) 2712 2749 … … 2714 2751 (define-arm-vinsn add-immediate (((dest t)) 2715 2752 ((src t) 2716 (upper :u32const) 2717 (lower :u32const))) 2718 ((:not (:pred = upper 0)) 2719 (addis dest src upper) 2720 ((:not (:pred = lower 0)) 2721 (addi dest dest lower))) 2722 ((:and (:pred = upper 0) (:not (:pred = lower 0))) 2723 (addi dest src lower))) 2724 2725 ;This must unbox one reg, but hard to tell which is better. 2726 ;(The one with the smaller absolute value might be) 2753 (imm :s32const))) 2754 (add dest src (:$ imm))) 2755 2727 2756 (define-arm-vinsn multiply-fixnums (((dest :imm)) 2728 2757 ((a :imm) 2729 2758 (b :imm)) 2730 2759 ((unboxed :s32))) 2731 (srawi unboxed b arm::fixnumshift) 2732 (mullw dest a unboxed)) 2733 2734 (define-arm-vinsn multiply-immediate (((dest :imm)) 2735 ((boxed :imm) 2736 (const :s16const))) 2737 (mulli dest boxed const)) 2760 (mov unboxed (:asr b (:$ arm::fixnumshift))) 2761 (mul dest a unboxed)) 2762 2763 2738 2764 2739 2765 ;;; Mask out the code field of a base character; the result … … 2741 2767 (define-arm-vinsn mask-base-char (((dest :u32)) 2742 2768 ((src :imm))) 2743 ( clrlwi dest src (- arm::nbits-in-word arm::charcode-shift)))2769 (and dest src (:$ arm::subtag-mask))) 2744 2770 2745 2771 ;;; Set dest (of type :s32!) to 0 iff VAL is an istruct of type TYPE … … 2747 2773 ((val :lisp) 2748 2774 (type :lisp)) 2749 ((crf :crf) 2750 (temp :lisp))) 2751 (clrlwi dest val (- arm::nbits-in-word arm::nlisptagbits)) 2752 (cmpwi crf dest arm::tag-misc) 2753 (li dest -1) 2754 (bne crf :done) 2755 (lbz dest arm::misc-subtag-offset val) 2756 (cmpwi crf dest arm::subtag-istruct) 2757 (bne crf :done) 2758 (lwz temp arm::misc-data-offset val) 2759 (subf dest type temp) 2760 :done) 2775 ((temp :lisp))) 2776 (and dest val (:$ arm::tagmask)) 2777 (cmp dest (:$ arm::tag-misc)) 2778 (ldrbeq dest (:@ val (:$ arm::misc-subtag-offset))) 2779 (cmp dest (:$ arm::subtag-istruct)) 2780 (movne dest (:$ -1)) 2781 (ldreq temp (:@ val (:$ arm::misc-data-offset))) 2782 (subeq dest type temp)) 2761 2783 2762 2784 … … 2771 2793 ((table :imm) 2772 2794 (idx :imm))) 2773 (lwz idx arm::symbol.binding-index src) 2774 (lwz table arm::tcr.tlb-limit arm::rcontext) 2775 (cmpw idx table) 2776 (lwz table arm::tcr.tlb-pointer arm::rcontext) 2777 (bge :symbol) 2778 (lwzx dest table idx) 2779 (cmpwi dest arm::subtag-no-thread-local-binding) 2780 (bne :done) 2781 :symbol 2782 (lwz dest arm::symbol.vcell src) 2783 :done 2784 (tweqi dest arm::unbound-marker)) 2795 (ldr idx (:@ src (:$ arm::symbol.binding-index))) 2796 (ldr table (:@ rcontext (:$ arm::tcr.tlb-limit))) 2797 (cmp idx table) 2798 (ldr table (:@ rcontext (:$ arm::tcr.tlb-pointer))) 2799 (movhs idx (:$ 0)) 2800 (ldr dest (:@ table idx)) 2801 (cmp dest (:$ arm::subtag-no-thread-local-binding)) 2802 (ldreq dest (:@ src (:$ arm::symbol.vcell))) 2803 (cmp dest (:$ arm::unbound-marker)) 2804 (uuo-error-unbound (:? eq) src)) 2785 2805 2786 2806 (define-arm-vinsn (%ref-symbol-value :call :subprim-call) … … 2793 2813 ((table :imm) 2794 2814 (idx :imm))) 2795 (lwz idx arm::symbol.binding-index src) 2796 (lwz table arm::tcr.tlb-limit arm::rcontext) 2797 (cmpw idx table) 2798 (lwz table arm::tcr.tlb-pointer arm::rcontext) 2799 (bge :symbol) 2800 (lwzx dest table idx) 2801 (cmpwi dest arm::subtag-no-thread-local-binding) 2802 (bne :done) 2803 :symbol 2804 (lwz dest arm::symbol.vcell src) 2805 :done 2806 ) 2815 (ldr idx (:@ src (:$ arm::symbol.binding-index))) 2816 (ldr table (:@ rcontext (:$ arm::tcr.tlb-limit))) 2817 (cmp idx table) 2818 (ldr table (:@ rcontext (:$ arm::tcr.tlb-pointer))) 2819 (movhs idx (:$ 0)) 2820 (ldr dest (:@ table idx)) 2821 (cmp dest (:$ arm::subtag-no-thread-local-binding)) 2822 (ldreq dest (:@ src (:$ arm::symbol.vcell)))) 2807 2823 2808 2824 (define-arm-vinsn (setq-special :call :subprim-call) … … 2817 2833 ((crf :crf) 2818 2834 (tag :u32))) 2819 (lwz val arm::symbol.fcell sym) 2820 (clrlwi tag val (- 32 arm::nlisptagbits)) 2821 (cmpwi crf tag arm::tag-misc) 2822 (bne- crf :bad) 2823 (lbz tag arm::misc-subtag-offset val) 2824 (cmpwi crf tag arm::subtag-function) 2825 (beq+ crf :good) 2826 :bad 2827 (uuo_interr arch::error-udf sym) 2828 :good) 2835 (ldr val (:@ sym (:$ arm::symbol.fcell))) 2836 (and tag val (:$ arm::tagmask)) 2837 (cmp tag (:$ arm::tag-misc)) 2838 (ldrbeq tag (:@ val (:$ arm::misc-subtag-offset))) 2839 (cmp tag (:$ arm::subtag-function)) 2840 (uuo-error-udf (:? ne) sym)) 2829 2841 2830 2842 (define-arm-vinsn (temp-push-unboxed-word :push :word :sp) … … 2835 2847 (orr header header (:$ (ash 1 arm::num-subtag-bits))) 2836 2848 (str header (:@ sp (:$ (- arm::dnode-size)))) 2837 (str w (:@ sp 4)))2849 (str w (:@ sp (:$ 4)))) 2838 2850 2839 2851 (define-arm-vinsn (temp-pop-unboxed-word :pop :word :sp) … … 2843 2855 (add sp sp (:$ arm::dnode-size))) 2844 2856 2857 #+notyet 2845 2858 (define-arm-vinsn (temp-push-double-float :push :doubleword :sp) 2846 2859 (() … … 2852 2865 (fstd d (:@ sp (:$ 8)))) 2853 2866 2867 #+notyet 2854 2868 (define-arm-vinsn (temp-pop-double-float :pop :doubleword :sp) 2855 2869 (() … … 2858 2872 (add sp sp (:$ (* 2 arm::dnode-size)))) 2859 2873 2874 #+notyet 2860 2875 (define-arm-vinsn (temp-push-single-float :push :word :tsp) 2861 2876 (() … … 2867 2882 (fsts s (:@ sp (:$ 4)))) 2868 2883 2884 #+notyet 2869 2885 (define-arm-vinsn (temp-pop-single-float :pop :word :sp) 2870 2886 (() … … 2881 2897 (define-arm-vinsn %current-tcr (((dest :imm)) 2882 2898 ()) 2883 (mov dest arm::rcontext))2899 (mov dest rcontext)) 2884 2900 2885 2901 (define-arm-vinsn (dpayback :call :subprim-call) (() … … 2893 2909 2894 2910 (define-arm-vinsn zero-double-float-register (((dest :double-float)) 2895 ()) 2896 (fmr dest arm::fp-zero)) 2911 () 2912 ((temp t))) 2913 (mov temp (:$ 0)) 2914 (fmsr dest temp)) 2897 2915 2898 2916 (define-arm-vinsn zero-single-float-register (((dest :single-float)) 2899 ()) 2900 (fmr dest arm::fp-zero)) 2917 () 2918 ((temp t))) 2919 (mov temp (:$ 0)) 2920 (fmdrr dest temp temp)) 2901 2921 2902 2922 (define-arm-vinsn load-double-float-constant (((dest :double-float)) … … 2917 2937 ((n :u16const))) 2918 2938 (cmp nargs (:$ (:apply ash n 2))) 2919 (uuo-error-wrong-nargs (: ne)))2939 (uuo-error-wrong-nargs (:? ne))) 2920 2940 2921 2941 (define-arm-vinsn check-min-nargs (() 2922 2942 ((min :u16const))) 2923 2943 (cmp nargs (:$ (:apply ash min 2))) 2924 (uuo-error-wrong-nargs (: lo)))2944 (uuo-error-wrong-nargs (:? lo))) 2925 2945 2926 2946 … … 2928 2948 ((max :u16const))) 2929 2949 (cmp nargs (:$ (:apply ash max 2))) 2930 (uuo-error-wrong-nargs (: hi)))2950 (uuo-error-wrong-nargs (:? hi))) 2931 2951 2932 2952 ;;; Save context and establish FN. The current VSP is the the … … 2936 2956 ((imm :u32))) 2937 2957 (mov imm (:$ arm::lisp-frame-marker)) 2938 (stmdb (:! sp) (imm vsp fn lr))) 2958 (stmdb (:! sp) (imm vsp fn lr)) 2959 (mov fn nfn)) 2939 2960 2940 2961 … … 2945 2966 (add imm vsp (:$ nbytes-vpushed)) 2946 2967 (mov imm0 (:$ arm::lisp-frame-marker)) 2947 (stmdb (:! sp) (imm0 imm fn lr))) 2968 (stmdb (:! sp) (imm0 imm fn lr)) 2969 (mov fn nfn)) 2948 2970 2949 2971 … … 2954 2976 ((imm :u32))) 2955 2977 (stwu arm::sp (- arm::lisp-frame.size) arm::sp) 2956 (st w arm::rzero arm::lisp-frame.savefn arm::sp)2957 (st w arm::loc-pc arm::lisp-frame.savelr arm::sp)2958 (st w arm::vsp arm::lisp-frame.savevsp arm::sp)2978 (str arm::rzero (:@ arm::sp (:$ arm::lisp-frame.savefn))) 2979 (str arm::loc-pc (:@ arm::sp (:$ arm::lisp-frame.savelr))) 2980 (str vsp (:@ arm::sp (:$ arm::lisp-frame.savevsp))) 2959 2981 (mr arm::fn arm::nfn) 2960 2982 ;; Do a stack-probe ... 2961 (l wz imm arm::tcr.cs-limit arm::rcontext)2983 (ldr imm (:@ rcontext (:$ arm::tcr.cs-limit))) 2962 2984 (twllt arm::sp imm)) 2963 2985 … … 2980 3002 (arg-temp :u32))) 2981 3003 ((:pred >= min-fixed $numarmargregs) 2982 (stwu arm::arg_x -4 arm::vsp)2983 (stwu arm::arg_y -4 arm::vsp)2984 (stwu arm::arg_z -4 arm::vsp))3004 (stwu arm::arg_x -4 vsp) 3005 (stwu arm::arg_y -4 vsp) 3006 (stwu arm::arg_z -4 vsp)) 2985 3007 ((:pred = min-fixed 2) ; at least 2 args 2986 3008 (cmplwi crfx nargs (ash 2 arm::word-shift)) 2987 3009 (beq crfx :yz2) ; skip arg_x if exactly 2 2988 (stwu arm::arg_x -4 arm::vsp)3010 (stwu arm::arg_x -4 vsp) 2989 3011 :yz2 2990 (stwu arm::arg_y -4 arm::vsp)2991 (stwu arm::arg_z -4 arm::vsp))3012 (stwu arm::arg_y -4 vsp) 3013 (stwu arm::arg_z -4 vsp)) 2992 3014 ((:pred = min-fixed 1) ; at least one arg 2993 3015 (cmplwi crfx nargs (ash 2 arm::word-shift)) 2994 3016 (blt crfx :z1) ; branch if exactly one 2995 3017 (beq crfx :yz1) ; branch if exactly two 2996 (stwu arm::arg_x -4 arm::vsp)3018 (stwu arm::arg_x -4 vsp) 2997 3019 :yz1 2998 (stwu arm::arg_y -4 arm::vsp)3020 (stwu arm::arg_y -4 vsp) 2999 3021 :z1 3000 (stwu arm::arg_z -4 arm::vsp))3022 (stwu arm::arg_z -4 vsp)) 3001 3023 ((:pred = min-fixed 0) 3002 3024 (cmplwi crfx nargs (ash 2 arm::word-shift)) … … 3006 3028 (blt crfx :z0) ; one 3007 3029 ; Three or more ... 3008 (stwu arm::arg_x -4 arm::vsp)3030 (stwu arm::arg_x -4 vsp) 3009 3031 :yz0 3010 (stwu arm::arg_y -4 arm::vsp)3032 (stwu arm::arg_y -4 vsp) 3011 3033 :z0 3012 (stwu arm::arg_z -4 arm::vsp)3034 (stwu arm::arg_z -4 vsp) 3013 3035 :none 3014 3036 ) 3015 3037 ((:pred = min-fixed 0) 3016 (stwu nargs -4 arm::vsp))3038 (stwu nargs -4 vsp)) 3017 3039 ((:not (:pred = min-fixed 0)) 3018 3040 (subi arg-temp nargs (:apply ash min-fixed arm::word-shift)) 3019 (stwu arg-temp -4 arm::vsp))3020 (add entry-vsp arm::vsp nargs)3041 (stwu arg-temp -4 vsp)) 3042 (add entry-vsp vsp nargs) 3021 3043 (la entry-vsp 4 entry-vsp) 3022 3044 (bl .SPlexpr-entry)) … … 3046 3068 (define-arm-vinsn restore-cleanup-context (() 3047 3069 ()) 3048 (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)) 3070 (ldr lr (:@ sp (:$ arm::lisp-frame.savelr))) 3049 3071 (add sp sp (:$ arm::lisp-frame.size))) 3050 3072 … … 3056 3078 (bne :done) 3057 3079 ((:pred >= min 3) 3058 (str arg_x (:@! vsp (:$ (- arm::node-size)))) 3080 (str arg_x (:@! vsp (:$ (- arm::node-size))))) 3059 3081 ((:pred >= min 2) 3060 3082 (mov arg_x arg_y)) 3061 3083 ((:pred >= min 1) 3062 3084 (mov arg_y arg_z)) 3063 (mov earm::arg_z (:$ arm::nil-value))3085 (mov arm::arg_z (:$ arm::nil-value)) 3064 3086 :done) 3065 3087 3066 3088 (define-arm-vinsn default-2-args (() 3067 3089 ((min :u16const))) 3068 (cmp nargs (: apply ash (:apply 1+ min) 2))3090 (cmp nargs (:$ (:apply ash (:apply 1+ min) 2))) 3069 3091 (bgt :done) 3070 3092 (beq :one) … … 3083 3105 (str arg_x (:@! vsp (:$ (- arm::node-size))))) 3084 3106 ((:pred >= min 1) 3085 (mov earg_x arg_y))3086 (m rarm::arg_y arm::arg_z)3107 (mov arg_x arg_y)) 3108 (mov arm::arg_y arm::arg_z) 3087 3109 :last 3088 3110 (mov arg_z (:$ arm::nil-value)) … … 3160 3182 (idx :imm)) 3161 3183 ((imm :u32))) 3162 (mov imm (: $lsr idx (:$ arm::fixnumshift)))3184 (mov imm (:lsr idx (:$ arm::fixnumshift))) 3163 3185 (add imm imm (:$ arm::misc-data-offset)) 3164 3186 (ldrb imm (:@ str imm)) … … 3182 3204 ((imm :u32) 3183 3205 (imm1 :u32))) 3184 (mov imm (:lsr (:$ idxarm::fixnumshift)))3206 (mov imm (:lsr idx (:$ arm::fixnumshift))) 3185 3207 (add imm imm (:$ arm::misc-data-offset)) 3186 (mov imm1 (:ls tchar (:$ arm::charcode-shift)))3208 (mov imm1 (:lsr char (:$ arm::charcode-shift))) 3187 3209 (strb imm1 (:@ str imm))) 3188 3210 … … 3215 3237 ((imm :u32) 3216 3238 (imm1 :u32))) 3217 (addi imm idx arm::misc-data-offset) 3218 (srwi imm1 code arm::fixnumshift) 3219 (stwx imm1 str imm) 3220 ) 3239 (add imm idx (:$ arm::misc-data-offset)) 3240 (mov imm1 (:lsr code (:$ arm::fixnumshift))) 3241 (str imm1 (:@ str imm))) 3221 3242 3222 3243 (define-arm-vinsn %scharcode8 (((code :imm)) 3223 3244 ((str :lisp) 3224 3245 (idx :imm)) 3225 ((imm :u32) 3226 (cr0 (:crf 0)))) 3227 (srwi imm idx arm::fixnumshift) 3228 (addi imm imm arm::misc-data-offset) 3229 (lbzx imm str imm) 3230 (slwi code imm arm::fixnumshift)) 3246 ((imm :u32))) 3247 (mov imm (:lsr idx (:$ arm::fixnumshift))) 3248 (add imm imm (:$ arm::misc-data-offset)) 3249 (ldrb imm (:@ str imm)) 3250 (mov code (:lsl imm (:$ arm::fixnumshift)))) 3231 3251 3232 3252 (define-arm-vinsn %scharcode32 (((code :imm)) 3233 3253 ((str :lisp) 3234 3254 (idx :imm)) 3235 ((imm :u32) 3236 (cr0 (:crf 0)))) 3237 (addi imm idx arm::misc-data-offset) 3238 (lwzx imm str imm) 3239 (slwi code imm arm::fixnumshift)) 3255 ((imm :u32))) 3256 (add imm idx (:$ arm::misc-data-offset)) 3257 (ldr imm (:@ str imm)) 3258 (mov code (:lsl imm (:$ arm::fixnumshift)))) 3240 3259 3241 3260 ;;; Clobbers LR 3242 (define-arm-vinsn (%debug-trap :call :subprim-call)(()3261 (define-arm-vinsn %debug-trap (() 3243 3262 ()) 3244 ( bl .SPbreakpoint)3245 ) 3246 3247 3263 (uuo-debug-trap)) 3264 3265 3266 #+notyet 3248 3267 (define-arm-vinsn eep.address (((dest t)) 3249 3268 ((src (:lisp (:ne dest ))))) 3250 (l wz dest (+ (ash 1 2) arm::misc-data-offset) src)3269 (ldr dest (:@ src (:$ (+ (ash 1 2) arm::misc-data-offset)))) 3251 3270 (tweqi dest (:apply target-nil-value))) 3252 3271 … … 3257 3276 (define-arm-vinsn %natural+-c (((dest :u32)) 3258 3277 ((x :u32) (y :u16const))) 3259 (add i dest x y))3278 (add dest x (:$ y))) 3260 3279 3261 3280 (define-arm-vinsn %natural- (((dest :u32)) … … 3265 3284 (define-arm-vinsn %natural--c (((dest :u32)) 3266 3285 ((x :u32) (y :u16const))) 3267 (sub i dest x y))3286 (sub dest x (:$ y))) 3268 3287 3269 3288 (define-arm-vinsn %natural-logior (((dest :u32)) 3270 3289 ((x :u32) (y :u32))) 3271 (or dest x y))3290 (orr dest x y)) 3272 3291 3273 3292 (define-arm-vinsn %natural-logior-c (((dest :u32)) 3274 ((x :u32) (high :u16const) (low :u16const))) 3275 ((:not (:pred = high 0)) 3276 (oris dest x high)) 3277 ((:not (:pred = low 0)) 3278 (ori dest x low))) 3293 ((x :u32) (c :u32const))) 3294 (orr dest x (:$ c))) 3279 3295 3280 3296 (define-arm-vinsn %natural-logxor (((dest :u32)) 3281 3297 ((x :u32) (y :u32))) 3282 ( xor dest x y))3298 (eor dest x y)) 3283 3299 3284 3300 (define-arm-vinsn %natural-logxor-c (((dest :u32)) 3285 ((x :u32) (high :u16const) (low :u16const))) 3286 ((:not (:pred = high 0)) 3287 (xoris dest x high)) 3288 ((:not (:pred = low 0)) 3289 (xori dest x low))) 3301 ((x :u32) (c :u32const))) 3302 (eor dest x (:$ c))) 3290 3303 3291 3304 (define-arm-vinsn %natural-logand (((dest :u32)) … … 3293 3306 (and dest x y)) 3294 3307 3295 (define-arm-vinsn %natural-logand-high-c (((dest :u32)) 3296 ((x :u32) (high :u16const)) 3297 ((cr0 (:crf 0)))) 3298 (andis. dest x high)) 3299 3300 (define-arm-vinsn %natural-logand-low-c (((dest :u64)) 3301 ((x :u64) (low :u16const)) 3302 ((cr0 (:crf 0)))) 3303 (andi. dest x low)) 3304 3305 (define-arm-vinsn %natural-logand-mask-c (((dest :u32)) 3306 ((x :u32) 3307 (start :u8const) 3308 (end :u8const))) 3309 (rlwinm dest x 0 start end)) 3308 (define-arm-vinsn %natural-logand-c (((dest :u32)) 3309 ((x :u32) (c :u16const)) 3310 ) 3311 (and dest x (:$ c))) 3312 3313 3314 3315 3316 3310 3317 3311 3318 (define-arm-vinsn disable-interrupts (((dest :lisp)) … … 3313 3320 ((temp :imm) 3314 3321 (temp2 :imm))) 3315 (l wz temp2 arm::tcr.tlb-pointer arm::rcontext)3316 ( li temp -4)3317 (l wz dest arm::interrupt-level-binding-index temp2)3318 (st w temp arm::interrupt-level-binding-index temp2))3322 (ldr temp2 (:@ rcontext (:$ arm::tcr.tlb-pointer))) 3323 (mov temp (:$ -4)) 3324 (ldr dest (:@ temp2 (:$ arm::interrupt-level-binding-index))) 3325 (str temp (:@ temp2 (:$ arm::interrupt-level-binding-index)))) 3319 3326 3320 3327 (define-arm-vinsn load-character-constant (((dest :lisp)) 3321 3328 ((code :u32const))) 3322 (ori dest arm::rzero (:apply logior (:apply ash (:apply logand #xff code) arm::charcode-shift) arm::subtag-character)) 3323 ((:not (:pred = 0 (:apply ldb (byte 16 8) code))) 3324 (oris dest dest (:apply ldb (byte 16 8) code)))) 3329 (mov dest (:$ arm::subtag-character)) 3330 ((:pred logtest #xff code) 3331 (orr dest dest (:$ (:apply ash (:apply logand code #xff) 8)))) 3332 ((:pred logtest #xff00 code) 3333 (orr dest dest (:$ (:apply ash (:apply ldb (byte 8 8) code) 16)))) 3334 ((:pred logtest #xff000 code) 3335 (orr dest dest (:$ (:apply ash (:apply ldb (byte 8 16) code) 24))))) 3325 3336 3326 3337 … … 3338 3349 (:apply %hard-regspec-value dest) 3339 3350 (:apply %hard-regspec-value src))) 3340 (m rdest src))3351 (mov dest src)) 3341 3352 (b :done) 3342 3353 :nilsym … … 3533 3544 (define-arm-subprim-call-vinsn (bind-interrupt-level-0) .SPbind-interrupt-level-0) 3534 3545 3546 #+notyet 3535 3547 (define-arm-vinsn bind-interrupt-level-0-inline (() 3536 3548 () … … 3539 3551 (link :imm) 3540 3552 (temp :imm))) 3541 (l wz tlb arm::tcr.tlb-pointer arm::rcontext)3542 (l wz value arm::interrupt-level-binding-index tlb)3543 (l wz link arm::tcr.db-link arm::rcontext)3553 (ldr tlb (:@ rcontext (:$ arm::tcr.tlb-pointer))) 3554 (ldr value (:@ tlb (:$ arm::interrupt-level-binding-index))) 3555 (ldr link (:@ rcontext (:$ arm::tcr.db-link))) 3544 3556 (cmpwi value 0) 3545 3557 (li temp arm::interrupt-level-binding-index) 3546 (stwu value -4 arm::vsp)3547 (stwu temp -4 arm::vsp)3548 (stwu link -4 arm::vsp)3549 (st w arm::rzero arm::interrupt-level-binding-index tlb)3550 (st w arm::vsp arm::tcr.db-link arm::rcontext)3558 (stwu value -4 vsp) 3559 (stwu temp -4 vsp) 3560 (stwu link -4 vsp) 3561 (str arm::rzero (:@ tlb (:$ arm::interrupt-level-binding-index))) 3562 (str vsp (:@ rcontext (:$ arm::tcr.db-link))) 3551 3563 (beq+ :done) 3552 3564 (mr nargs value) 3553 3565 (bgt :do-trap) 3554 (l wz nargs arm::tcr.interrupt-pending arm::rcontext)3566 (ldr nargs (:@ rcontext (:$ arm::tcr.interrupt-pending))) 3555 3567 :do-trap 3556 3568 (twgti nargs 0) … … 3568 3580 (newvalue :imm) 3569 3581 (idx :imm))) 3570 (li newvalue (ash -1 arm::fixnumshift)) 3571 (li idx arm::interrupt-level-binding-index) 3572 (lwz tlb arm::tcr.tlb-pointer arm::rcontext) 3573 (lwz oldvalue arm::interrupt-level-binding-index tlb) 3574 (lwz link arm::tcr.db-link arm::rcontext) 3575 (stwu oldvalue -4 arm::vsp) 3576 (stwu idx -4 arm::vsp) 3577 (stwu link -4 arm::vsp) 3578 (stw newvalue arm::interrupt-level-binding-index tlb) 3579 (stw arm::vsp arm::tcr.db-link arm::rcontext) 3580 :done) 3582 (mov newvalue (:$ (ash -1 arm::fixnumshift))) 3583 (mov idx (:$ arm::interrupt-level-binding-index)) 3584 (ldr tlb (:@ rcontext (:$ arm::tcr.tlb-pointer))) 3585 (ldr oldvalue (:@ tlb (:$ arm::interrupt-level-binding-index))) 3586 (ldr link (:@ rcontext (:$ arm::tcr.db-link))) 3587 (str oldvalue (:@! vsp (:$ (- arm::node-size)))) 3588 (str idx (:@! vsp (:$ (- arm::node-size)))) 3589 (str link (:@! vsp (:$ (- arm::node-size)))) 3590 (str newvalue (:@ tlb (:$ arm::interrupt-level-binding-index))) 3591 (str vsp (:@ rcontext (:$ arm::tcr.db-link)))) 3581 3592 3582 3593 (define-arm-subprim-call-vinsn (bind-interrupt-level) .SPbind-interrupt-level) … … 3584 3595 (define-arm-subprim-call-vinsn (unbind-interrupt-level) .SPunbind-interrupt-level) 3585 3596 3597 #+notyet 3586 3598 (define-arm-vinsn unbind-interrupt-level-inline (() 3587 3599 () … … 3592 3604 (crf0 :crf) 3593 3605 (crf1 :crf))) 3594 (l wz tlb arm::tcr.tlb-pointer arm::rcontext)3595 (l wz value arm::interrupt-level-binding-index tlb)3596 (l wz link arm::tcr.db-link arm::rcontext)3606 (ldr tlb (:@ rcontext (:$ arm::tcr.tlb-pointer))) 3607 (ldr value (:@ tlb (:$ arm::interrupt-level-binding-index))) 3608 (ldr link (:@ rcontext (:$ arm::tcr.db-link))) 3597 3609 (cmpwi crf1 value 0) 3598 (l wz value 8 link)3599 (l wz link 0 link)3610 (ldr value (:@ link (:$ 8))) 3611 (ldr link (:@ link (:$ 0))) 3600 3612 (cmpwi crf0 value 0) 3601 (st w value arm::interrupt-level-binding-index tlb)3602 (st w link arm::tcr.db-link arm::rcontext)3613 (str value (:@ tlb (:$ arm::interrupt-level-binding-index))) 3614 (str link (:@ rcontext (:$ arm::tcr.db-link))) 3603 3615 (bge crf1 :done) 3604 3616 (blt crf0 :done) 3605 3617 (mr save-nargs nargs) 3606 (l wz nargs arm::tcr.interrupt-pending arm::rcontext)3618 (ldr nargs (:@ rcontext (:$ arm::tcr.interrupt-pending))) 3607 3619 (twgti nargs 0) 3608 3620 (mr nargs save-nargs) … … 3614 3626 ((arg :lisp) 3615 3627 (lab :label)) 3616 ((cr0 (:crf 0)) 3617 (tag :u8))) 3618 (clrlwi. tag arg (- arm::nbits-in-word arm::nlisptagbits)) 3619 (bne cr0 lab)) 3628 ()) 3629 (tst arg (:$ arm::fixnummask)) 3630 (bne lab)) 3631 3632 3633 3620 3634 3621 3635 (define-arm-vinsn branch-unless-both-args-fixnums (() … … 3625 3639 ((tag :u8))) 3626 3640 (orr tag arg0 arg1) 3627 (tst tag (:$ arm:: tagmask))3641 (tst tag (:$ arm::fixnummask)) 3628 3642 (bne lab)) 3629 3643 3630 3644 ;;; In case arm::*arm-opcodes* was changed since this file was compiled. 3645 #+maybe-never 3631 3646 (queue-fixup 3632 3647 (fixup-vinsn-templates *arm-vinsn-templates* arm::*arm-opcode-numbers*)) -
branches/arm/compiler/ARM/arm2.lisp
r13714 r13741 503 503 (setf (uvref function (1+ 2)) (aref imms i))) 504 504 (setf (uvref function (+ numimms 1)) bits) 505 (let* ((maxpc (arm-lap-encode-regsave-info (arm-lap-do-labels))) 506 (code-vector-size (+ traceback-size (ash maxpc -2) prefix-size))) 507 (let* ((code-vector (%alloc-misc code-vector-size 505 (let* ((code-vector-size (arm::arm-finalize code data)) 506 (code-vector (%alloc-misc code-vector-size 508 507 (if cross-compiling 509 508 target::subtag-xcode-vector 510 509 target::subtag-code-vector))) 511 (j 0)) 512 (dotimes (i prefix-size) 513 (setf (uvref code-vector i) (pop prefix))) 514 (arm-lap-resolve-labels) 515 (do-dll-nodes (insn *lap-instructions*) 516 (arm-lap-generate-instruction code-vector i insn) 517 (incf i)) 518 (unless (eql 0 traceback-size) 519 (add-traceback-table code-vector i traceback-string)) 520 (setf (uvref function 0) code-vector) 521 (%make-code-executable code-vector) 522 function)))) 510 (j 0)) 511 (dotimes (i prefix-size) 512 (setf (uvref code-vector i) (pop prefix))) 513 (arm-lap-resolve-labels) 514 (do-dll-nodes (insn *lap-instructions*) 515 (arm-lap-generate-instruction code-vector i insn) 516 (incf i)) 517 (setf (uvref function 1) code-vector) 518 (%make-code-executable code-vector) 519 function))) 523 520 524 521 … … 816 813 (reg-vars ())) 817 814 (declare (type (unsigned-byte 16) nargs)) 818 (! save-lr)819 815 (if (<= nargs $numarmargregs) ; caller didn't vpush anything 820 (if *arm2-open-code-inline* 821 (! save-lisp-context-vsp) 822 (! save-lisp-context-vsp-ool)) 816 (! save-lisp-context-vsp) 823 817 (let* ((offset (* (the fixnum (- nargs $numarmargregs)) *arm2-target-node-size*))) 824 818 (declare (fixnum offset)) 825 (if *arm2-open-code-inline* 826 (! save-lisp-context-offset offset) 827 (! save-lisp-context-offset-ool offset)))) 819 (! save-lisp-context-offset offset))) 828 820 (destructuring-bind (&optional zvar yvar xvar &rest stack-args) revargs 829 821 (let* ((nstackargs (length stack-args))) … … 4777 4769 (or (eq cd $backend-return) (arm2-mvpass-p cd))) 4778 4770 4779 (defun arm2-expand-note (note )4771 (defun arm2-expand-note (note header) 4780 4772 (let* ((lab (vinsn-note-label note))) 4781 4773 (case (vinsn-note-class note) 4782 4774 ((:begin-variable-scope :end-variable-scope 4783 4775 :source-location-begin :source-location-end) 4784 (setf (vinsn-label-info lab) ( emit-lap-labellab))))))4776 (setf (vinsn-label-info lab) (arm::emit-lap-label header lab)))))) 4785 4777 4786 4778 (defun arm2-expand-vinsns (header current sections) … … 4791 4783 (when (or t (vinsn-label-refs v) (null id)) 4792 4784 (setf (vinsn-label-info v) (arm::emit-lap-label current v))) 4793 (arm2-expand-note id)))4785 (arm2-expand-note current id))) 4794 4786 (setq current (arm2-expand-vinsn v current sections)))) 4795 4787 ;;; This doesn't have too much to do with anything else that's … … 5337 5329 (let* ((fixval (or fix1 fix2)) 5338 5330 (unboxed-fixval (if fixval (ash fixval *arm2-target-fixnum-shift*))) 5339 ( high (if fixval (if (= unboxed-fixval (logand #xffff0000 unboxed-fixval)) (ash unboxed-fixval -16))))5340 (low (if fixval (unless high (if (= unboxed-fixval (logand #x0000ffff unboxed-fixval)) unboxed-fixval))))5341 (otherform (if (or high low)(if fix1 form2 form1))))5331 (ok-imm (and unboxed-fixval 5332 (arm::encode-arm-immediate unboxed-fixval))) 5333 (otherform (if ok-imm (if fix1 form2 form1)))) 5342 5334 (if otherform 5343 5335 (let* ((other-reg (arm2-one-untargeted-reg-form seg otherform arm::arg_z))) 5344 5336 (when vreg 5345 (ensuring-node-target (target vreg) 5346 (if high 5347 (! logior-high target other-reg high) 5348 (! logior-low target other-reg low))))) 5337 (ensuring-node-target (target vreg) 5338 (! logior-immediate target other-reg unboxed-fixval)))) 5349 5339 (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg form1 arm::arg_y form2 arm::arg_z) 5350 5340 (if vreg (ensuring-node-target (target vreg) (! %logior2 target r1 r2))))) 5351 5341 (^)))) 5352 5342 5353 ;;; in a lot of (typical ?) cases, it might be possible to use a5354 ;;; rotate-and-mask instead of andi./andis.5355 5343 5356 5344 (defarm2 arm2-%ilogand2 %ilogand2 (seg vreg xfer form1 form2) … … 5360 5348 (arm2-use-operator (%nx1-operator fixnum) seg vreg xfer (logand fix1 fix2)) 5361 5349 (let* ((fixval (or fix1 fix2)) 5362 (fixlen (if fixval (integer-length fixval))) 5363 (unboxed-fixval (if fixval (ash fixval *arm2-target-fixnum-shift*))) 5364 (high (if fixval (if (= unboxed-fixval (logand #xffff0000 unboxed-fixval)) (ash unboxed-fixval -16)))) 5365 (low (if fixval (unless high (if (= unboxed-fixval (logand #x0000ffff unboxed-fixval)) unboxed-fixval)))) 5366 (otherform (if (or high low) (if fix1 form2 form1)))) 5350 (unboxed-fixval (if fixval (ash fixval arm::fixnum-shift))) 5351 (ok-imm (and unboxed-fixval 5352 (or (arm::encode-arm-immediate unboxed-fixval) 5353 (arm::encode-arm-immediate 5354 (logand #xffffffff (lognot unboxed-fixval)))))) 5355 5356 (otherform (if ok-imm (if fix1 form2 form1)))) 5367 5357 (if otherform 5368 5358 (let* ((other-reg (arm2-one-untargeted-reg-form seg otherform arm::arg_z))) 5369 5359 (when vreg 5370 (ensuring-node-target (target vreg) 5371 (if high 5372 (! logand-high target other-reg high) 5373 (! logand-low target other-reg low))))) 5374 (if (and fixval (= fixlen (logcount fixval))) 5375 (let* ((nbits (- *arm2-target-bits-in-word* 5376 (1+ (+ *arm2-target-fixnum-shift* fixlen)))) 5377 (otherreg (arm2-one-untargeted-reg-form seg (if fix1 form2 form1) arm::arg_z))) 5378 5379 (if vreg (ensuring-node-target (target vreg) 5380 (if (> fixval 0) 5381 (! clear-left target otherreg nbits) 5382 (! clear-right target otherreg (+ fixlen 5383 *arm2-target-fixnum-shift*)))))) 5384 5360 (ensuring-node-target (target vreg) 5361 (! logand-immediate target other-reg unboxed-fixval)))) 5385 5362 (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg form1 arm::arg_y form2 arm::arg_z) 5386 (if vreg (ensuring-node-target (target vreg) (! %logand2 target r1 r2))))) )5363 (if vreg (ensuring-node-target (target vreg) (! %logand2 target r1 r2))))) 5387 5364 (^))))) 5388 5365 … … 7778 7755 (defarm2 arm2-%setf-double-float %setf-double-float (seg vref xfer fnode fval) 7779 7756 (arm2-vpush-register seg (arm2-one-untargeted-reg-form seg fnode arm::arg_z)) 7780 (let* ((target ($ arm:: fp1:class :fpr :mode :double-float))7757 (let* ((target ($ arm::d0 :class :fpr :mode :double-float)) 7781 7758 (node ($ arm::arg_z))) 7782 7759 (arm2-one-targeted-reg-form seg fval target) … … 7790 7767 (defarm2 arm2-%setf-short-float %setf-short-float (seg vreg xfer fnode fval) 7791 7768 (arm2-vpush-register seg (arm2-one-untargeted-reg-form seg fnode arm::arg_z)) 7792 (let* ((target ($ arm:: fp1:class :fpr :mode :single-float))7769 (let* ((target ($ arm::s0 :class :fpr :mode :single-float)) 7793 7770 (freg ($ arm::arg_z))) 7794 7771 (arm2-one-targeted-reg-form seg fval target)
Note: See TracChangeset
for help on using the changeset viewer.