Index: /branches/arm/compiler/ARM/arm-arch.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-arch.lisp (revision 13740) +++ /branches/arm/compiler/ARM/arm-arch.lisp (revision 13741) @@ -37,5 +37,13 @@ (let* ((value (get-arm-register name))) (and value (< value 16) value))) - + +(defun get-arm-sfpr (name) + (let* ((value (get-arm-register name))) + (and value (logbitp 5 value) (logand #x1f value)))) + +(defun get-arm-dfpr (name) + (let* ((value (get-arm-register name))) + (and value (logbitp 6 value) (logand #x0f value)))) + ;;; This allows redefinition, which might be helpful while @@ -96,4 +104,6 @@ (defarmgpr pc r15) + + ;;; Calling sequence may pass additional arguments in temp registers. ;;; "nfn" (new function) is always passed; it's the new value of "fn". @@ -107,4 +117,62 @@ (defarmgpr nargs imm2) +(defmacro defarmsfpr (name val) + `(defconstant ,name (define-arm-register ',name ',val))) + +(defarmsfpr s0 32) +(defarmsfpr s1 33) +(defarmsfpr s2 34) +(defarmsfpr s3 35) +(defarmsfpr s4 36) +(defarmsfpr s5 37) +(defarmsfpr s6 38) +(defarmsfpr s7 39) +(defarmsfpr s8 40) +(defarmsfpr s9 41) +(defarmsfpr s10 42) +(defarmsfpr s11 43) +(defarmsfpr s12 44) +(defarmsfpr s13 45) +(defarmsfpr s14 46) +(defarmsfpr s15 47) +(defarmsfpr s16 48) +(defarmsfpr s17 49) +(defarmsfpr s18 50) +(defarmsfpr s19 51) +(defarmsfpr s20 52) +(defarmsfpr s21 53) +(defarmsfpr s22 54) +(defarmsfpr s23 55) +(defarmsfpr s24 56) +(defarmsfpr s25 57) +(defarmsfpr s26 58) +(defarmsfpr s27 59) +(defarmsfpr s28 60) +(defarmsfpr s29 61) +(defarmsfpr s30 62) +(defarmsfpr s31 63) + +;;; The first 16 double-float registers overlap pairs of single-float +;;; registers (d0 overlaps s0-s1, d15 overlaps s30-s31, etc.) + +(defmacro defarmdfpr (name val) + `(defconstant ,name (define-arm-register ',name ',val))) + +(defarmdfpr d0 64) +(defarmdfpr d1 65) +(defarmdfpr d2 66) +(defarmdfpr d3 67) +(defarmdfpr d4 68) +(defarmdfpr d5 69) +(defarmdfpr d6 70) +(defarmdfpr d7 71) +(defarmdfpr d8 72) +(defarmdfpr d9 73) +(defarmdfpr d10 74) +(defarmdfpr d11 75) +(defarmdfpr d12 76) +(defarmdfpr d13 77) +(defarmdfpr d14 78) +(defarmdfpr d15 79) @@ -218,5 +286,5 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *arm-subprims-shift* 8) -(defparameter *arm-subprims-base* (ash 4 12) ) +(defparameter *arm-subprims-base* (ash 9 12) ) ) (defvar *arm-subprims*) @@ -229,4 +297,6 @@ (ccl::make-subprimitive-info :name (string name) :offset (prog1 origin + (when (= origin #x10000) + (setq step (ash 1 10))) (incf origin step))))) (macrolet ((defarmsubprim (name) @@ -449,4 +519,6 @@ (defconstant target-most-negative-fixnum (ash -1 (1- (- nbits-in-word nfixnumtagbits)))) (defconstant target-most-positive-fixnum (1- (ash 1 (1- (- nbits-in-word nfixnumtagbits))))) +(defconstant fixnumone (ash 1 fixnumshift)) + @@ -1313,6 +1385,4 @@ al) -(defconstant arm-cond-eq 0) -(def (provide "ARM-ARCH") Index: /branches/arm/compiler/ARM/arm-asm.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-asm.lisp (revision 13740) +++ /branches/arm/compiler/ARM/arm-asm.lisp (revision 13741) @@ -94,42 +94,34 @@ (eval-when (:compile-toplevel :load-toplevel :execute) -(ccl::defenum (:prefix "ARM-OPERAND-TYPE-") - rd ; destination register in bits 12:15 - rn ; unshifted source/base reg in 16:19 - shifter ; composite operand for ALU ops - mem12 ; 12-bit address for LDR/STR/LDRB/STB - reglist - rnw ; rn, with optional writeback. - uuoA ; GPR in UUO bits 8:11 - uuo-unary ; constant in UUO bits 12:15 - uuoB ; GPR in UUO bits 12:15 - rm - b - subprim - mem8 -) - -(defparameter *arm-operand-type-names* - `((:rd . ,arm-operand-type-rd) - (:rn . ,arm-operand-type-rn) - (:shifter . ,arm-operand-type-shifter) - (:mem12 . ,arm-operand-type-mem12) - (:reglist . ,arm-operand-type-reglist) - (:rnw . ,arm-operand-type-rnw) - (:uuoA . ,arm-operand-type-uuoA) - (:uuo-unary . ,arm-operand-type-uuo-unary) - (:uuoB . ,arm-operand-type-uuoB) - (:rm . ,arm-operand-type-rm) - (:b . ,arm-operand-type-b) - (:subprim . ,arm-operand-type-subprim) - (:mem8 . ,arm-operand-type-mem8) +(defparameter *arm-operand-types* + #(:rd ; destination register in bits 12:15 + :rn ; unshifted source/base reg in 16:19 + :shifter ; composite operand for ALU ops + :mem12 ; 12-bit address for LDR/STR/LDRB/STB + :reglist + :rnw ; rn, with optional writeback. + :uuoA ; GPR in UUO bits 8:11 + :uuo-unary ; constant in UUO bits 12:15 + :uuoB ; GPR in UUO bits 12:15 + :rm + :b + :subprim + :mem8 + :dd + :dm + :sd + :sm + :dn + :sn + :rde + :rs )) - - - -(defun encode-arm-operand-type (name) - (or (cdr (assoc name *arm-operand-type-names* :test #'eq)) +(defun %encode-arm-operand-type (name) + (or (position name *arm-operand-types* :test #'eq) (error "Unknown ARM operand type name ~s." name))) + +(defmacro encode-arm-operand-type (name) + (%encode-arm-operand-type name)) (ccl::defenum (:prefix "ARM-INSTRUCTION-FLAG-") @@ -172,5 +164,5 @@ (defmacro define-arm-instruction (name operand-type-names value mask-list flag-names) - `(%define-arm-instruction ,(string-downcase name) ,value ',mask-list ,(%encode-arm-instruction-flag flag-names) ',(mapcar #'encode-arm-operand-type operand-type-names) )) + `(%define-arm-instruction ,(string-downcase name) ,value ',mask-list ,(%encode-arm-instruction-flag flag-names) ',(mapcar #'%encode-arm-operand-type operand-type-names) )) (defparameter *arm-instruction-table* @@ -185,21 +177,21 @@ (:prefer-separate-cond)) (define-arm-instruction uuo-error-wrong-nargs () - #x07f000f1 + #x07f001f8 #x0fffffff (:prefer-separate-cond)) (define-arm-instruction uuo-gc-trap () - #x07f001f2 + #x07f002f0 #x0fffffff (:prefer-separate-cond)) (define-arm-instruction uuo-debug-trap () - #x07f002f3 + #x07f002f0 #x0fffffff (:prefer-separate-cond)) (define-arm-instruction uuo-interrupt-now () - #x07f003f4 + #x07f003f0 #x0fffffff (:prefer-separate-cond)) (define-arm-instruction uuo-suspend-now () - #x07f004f05 + #x07f004f0 #x0fffffff (:prefer-separate-cond)) @@ -232,13 +224,13 @@ ;;; Unary UUOs (define-arm-instruction uuo-error-unbound (:uuoA) - #x07f000f1 + #x07f000f9 #x0ffff0ff (:prefer-separate-cond)) (define-arm-instruction uuo-cerror-unbound (:uuoA) - #x07f010f1 + #x07f010f9 #x0ffff0ff (:prefer-separate-cond)) (define-arm-instruction uuo-error-not-callable (:uuoA) - #x07f020f1 + #x07f020f9 #x0ffff0ff (:prefer-separate-cond)) @@ -248,8 +240,16 @@ (:prefer-separate-cond)) (define-arm-instruction uuo-error-no-throw-tag (:uuoA) - #x07f040f1 + #x07f040f9 #x0ffff0ff (:prefer-separate-cond)) - + (define-arm-instruction uuo-error-udf-call (:uuoA) + #x07f050f9 + #x0ffff0ff + (:prefer-separate-cond)) + (define-arm-instruction uuo-error-udf (:uuoA) + #x07f060f9 + #x0ffff0ff + (:prefer-separate-cond)) + ;;; Binary UUOs (define-arm-instruction uuo-error-vector-bounds (:uuoA :uuoB) @@ -261,5 +261,12 @@ #x0fff00ff (:prefer-separate-cond)) - + (define-arm-instruction uuo-error-integer-divide-by-zero (:uuoA :uuoB) + #x07f200ff + #x0fff00ff + (:prefer-separate-cond)) + (define-arm-instruction uuo-error-slot-unbound (:uuoA :uuoB) + #x07f300ff + #x0fff00ff + (:prefer-separate-cond)) (define-arm-instruction and (:rd :rn :shifter) @@ -484,5 +491,22 @@ #x0e3000f0 ()) - + (define-arm-instruction ldrd (:rde :mem8) + #x000000d0 + #x0e3000f0 + ()) + (define-arm-instruction strd (:rde :mem8) + #x000000f0 + #x0e3000f0 + ()) + + (define-arm-instruction mul (:rd :rm :rs) + #x00000090 + #x0ff000f0 + ()) + (define-arm-instruction muls (:rd :rm :rs) + #x00100090 + #x0ff000f0 + ()) + (define-arm-instruction stm (:rnw :reglist) #x08800000 @@ -545,4 +569,94 @@ #x012fff30 #x0ffffff0 + ()) + +;;; VFP instructions + (define-arm-instruction fabsd (:dd :dm) + #x0eb00bc0 + #x0ff00ff0 + ()) + (define-arm-instruction fabss (:sd :sm) + #x0eb00ac0 + #x0fb00fb0 + ()) + (define-arm-instruction faddd (:dd :dn :dm) + #x0e300b00 + #x0ff00ff0 + ()) + (define-arm-instruction fadds (:sd :sn :sm) + #x0e300a00 + #x0f300f50 + ()) + (define-arm-instruction fmsr (:sn :rd) + #x0e000a10 + #x0ff00f90 + ()) + (define-arm-instruction fmrs (:rd :sn) + #x0e100a10 + #x0ff00f90 + ()) + (define-arm-instruction fmrrd (:rd :rn :dm) + #x0e500b10 + #x0ff00ff0 + ()) + (define-arm-instruction fmdrr (:dm :rd :rn) + #x0e400b10 + #x0ff00ff0 + ()) + (define-arm-instruction fsitod (:dd :sm) + #x0eb80bc0 + #x0fff0fc0 + ()) + (define-arm-instruction fsitos (:sd :sm) + #x0eb80ac0 + #x0fff0fc0 + ()) + (define-arm-instruction fcmped (:dd :dm) + #x0eb40bc0 + #x0fff0fc0 + ()) + (define-arm-instruction fcmpes (:dd :dm) + #x0eb40ac0 + #x0fff0fc0 + ()) + (define-arm-instruction fmstat () + #x0ef1fa10 + #x0fffffff + ()) + (define-arm-instruction fsubd (:dd :dn :dm) + #x0e300b40 + #x0ff00fc0 + ()) + (define-arm-instruction fsubs (:sd :sn :sm) + #x0e300a40 + #x0ff00fc0 + ()) + (define-arm-instruction fmuld (:dd :dn :dm) + #x0e200b00 + #x0ff00ff0 + ()) + (define-arm-instruction fmuls (:sd :sn :sm) + #x0e200a00 + #x0ff00ff0 + ()) + (define-arm-instruction fdivd (:dd :dn :dm) + #x0e800b00 + #x0ff00ff0 + ()) + (define-arm-instruction fdivs (:sd :sn :sm) + #x0e800a00 + #x0ff00ff0 + ()) + (define-arm-instruction fcpyd (:dd :dm) + #x0eb00b40 + #x0fb00ff0 + ()) + (define-arm-instruction fcpyd (:sd :sm) + #x0eb00b40 + #x0fb00fc0 + ()) + (define-arm-instruction fcvtsd (:sd :dm) + #x0eb70bc0 + #x0fbf0fc0 ()) )) @@ -667,4 +781,12 @@ (or (get-arm-gpr form) (error "Expected an ARM general-purpose register, got ~s" form))) + +(defun need-arm-sfpr (form) + (or (get-arm-sfpr form) + (error "Expected an ARM single FP register, got ~s" form))) + +(defun need-arm-dfpr (form) + (or (get-arm-sfpr form) + (error "Expected an ARM double FP register, got ~s" form))) (defun encode-arm-shift-type (op) @@ -943,9 +1065,37 @@ (set-addressing-mode instruction mode constant-index)))) - - +(defun parse-dd-operand (form instruction) + (set-field-value instruction (byte 4 12) (need-arm-dfpr form))) + +(defun parse-dm-operand (form instruction) + (set-field-value instruction (byte 4 0) (need-arm-dfpr form))) + +(defun parse-sd-operand (form instruction) + (let* ((val (need-arm-sfpr form))) + (set-field-value instruction (byte 4 12) (ash val -1)) + (set-field-value instruction (byte 1 22) (logand val 1)))) + +(defun parse-sm-operand (form instruction) + (let* ((val (need-arm-sfpr form))) + (set-field-value instruction (byte 4 0) (ash val -1)) + (set-field-value instruction (byte 1 5) (logand val 1)))) + +(defun parse-dn-operand (form instruction) + (set-field-value instruction (byte 4 16) (need-arm-dfpr form))) - - +(defun parse-sn-operand (form instruction) + (let* ((val (need-arm-sfpr form))) + (set-field-value instruction (byte 4 16) (ash val -1)) + (set-field-value instruction (byte 1 7) (logand val 1)))) + +(defun parse-rde-operand (form instruction) + (let* ((val (need-arm-gpr form))) + (when (oddp val) + (error "Register must be even-numbered: ~s." form)) + (set-field-value instruction (byte 4 12) val))) + +(defun parse-rs-operand (form instruction) + (set-field-value instruction (byte 4 8) (need-arm-gpr form))) + (defparameter *arm-operand-parsers* #(parse-rd-operand @@ -962,4 +1112,12 @@ parse-subprim-operand parse-m8-operand + parse-dd-operand + parse-dm-operand + parse-sd-operand + parse-sm-operand + parse-dn-operand + parse-sn-operand + parse-rde-operand + parse-rs-operand )) @@ -1102,5 +1260,5 @@ (ccl::append-dll-node w1 primary ) (let* ((n (set-element-addresses 0 primary))) - (setf (lap-instruction-opcode w1) n) + (setf (lap-instruction-opcode w1) (ash n (- arm::word-shift))) (set-element-addresses n constant-pool))) ;; Now fix up label references. Recall that the PC value at some @@ -1187,4 +1345,5 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *vinsn-field-types* #(:cond @@ -1206,5 +1365,11 @@ :application :local-label - )) + :dd + :dm + :sd + :sm + :dn + :sn + ))) (defmacro encode-vinsn-field-type (name) @@ -1226,4 +1391,12 @@ vinsn-parse-subprim-operand vinsn-parse-m8-operand + vinsn-parse-dd-operand + vinsn-parse-dm-operand + vinsn-parse-sd-operand + vinsn-parse-sm-operand + vinsn-parse-dn-operand + vinsn-parse-sn-operand + vinsn-parse-rde-operand + vinsn-parse-rs-operand )) @@ -1236,4 +1409,37 @@ (set-avi-opcode-field avi bytespec (need-arm-gpr form)))))) +(defun vinsn-arg-or-dfpr (avi form vinsn-params encoded-type bytespec) + (let* ((p (position form vinsn-params))) + (cond (p + (add-avi-operand avi encoded-type p) + nil) + (t + (set-avi-opcode-field avi bytespec (need-arm-dfpr form)))))) + +(defun vinsn-arg-or-sfpr (avi form vinsn-params encoded-type top4 low1) + (let* ((p (position form vinsn-params))) + (cond (p + (add-avi-operand avi encoded-type p) + nil) + (t + (let* ((val (need-arm-sfpr form))) + (set-avi-opcode-field avi top4 (ash val -1)) + (set-avi-opcode-field avi low1 (logand val 1))))))) + +(defun simplify-arm-vinsn-application (form params) + (labels ((simplify-operand (op) + (if (atom op) + (if (typep form 'fixnum) + op + (if (constantp op) + (eval op) + (let* ((p (position op params))) + (if p + (list p) + (error "Unknown operand: ~s" op))))) + (if (eq (car op) :apply) + `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op))))))) + `(,(cadr form) ,@(mapcar #'simplify-operand (cddr form))))) + (defun vinsn-arg-or-constant (avi form vinsn-params encoded-type bytespec) (let* ((p (position form vinsn-params))) @@ -1241,6 +1447,9 @@ (add-avi-operand avi encoded-type p) nil) + ((typep form 'keyword) + (add-avi-operand avi encoded-type form) + nil) ((and (consp form) (eq (car form) :apply)) - (add-avi-operand avi encoded-type (simplify-application form vinsn-params)) + (add-avi-operand avi encoded-type (simplify-arm-vinsn-application form vinsn-params)) nil) (t @@ -1300,4 +1509,6 @@ (defun vinsn-parse-m12-operand (avi value vinsn-params) + (when (typep value 'keyword) + (setq value `(:@ arm::pc (:$ ,value)))) (destructuring-bind (op rn index) value ; no (:@ reg) sugar (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16)) @@ -1350,6 +1561,6 @@ (destructuring-bind (marker reg) value (if (eq marker :!) - (set-avi-opcode-field avi (byte 1 21) 1)) - (error "Unrecognized writeback indicator in ~s." value) + (set-avi-opcode-field avi (byte 1 21) 1) + (error "Unrecognized writeback indicator in ~s." value)) reg)))) (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16)))) @@ -1378,4 +1589,6 @@ ((typep value 'keyword) (add-avi-operand avi (encode-vinsn-field-type :local-label) value)) + ((arm-subprimitive-address value) + (add-avi-operand avi (encode-vinsn-field-type :subprim) value)) (t (error "Unknown branch target: ~s." value))))) @@ -1434,52 +1647,104 @@ (set-opcode-value-from-addressing-mode (avi-opcode avi) mode constant-index)))))) - - - - +(defun vinsn-parse-dd-operand (avi value vinsn-params) + (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dd) (byte 4 12))) + +(defun vinsn-parse-dm-operand (avi value vinsn-params) + (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dm) (byte 4 0))) + +(defun vinsn-parse-sd-operand (avi value vinsn-params) + (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sd) (byte 4 12) (byte 1 22))) + +(defun vinsn-parse-sm-operand (avi value vinsn-params) + (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sm) (byte 4 0) (byte 1 5))) + +(defun vinsn-parse-dn-operand (avi value vinsn-params) + (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dn) (byte 4 16))) + +(defun vinsn-parse-sn-operand (avi value vinsn-params) + (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sn) (byte 4 16) (byte 1 7))) + +(defun vinsn-parse-rde-operand (avi value vinsn-params) + (let* ((val (get-arm-gpr value))) + (when (and val (oddp val)) + (error "Register ~s must be even-numbered." value))) + (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rd) (byte 4 12))) + +(defun vinsn-parse-rs-operand (avi value vinsn-params) + (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rs) (byte 4 8))) + (defun vinsn-simplify-instruction (form vinsn-params) (destructuring-bind (name . opvals) form - (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name) - (unless template - (error "Unknown ARM instruction - ~s" form)) - (let* ((cond-indicator (and (consp (car opvals)) - (keywordize (caar opvals)))) - (avi (make-arm-vinsn-instruction (arm-instruction-template-val template)))) - (when (or (eq cond-indicator :?) - (eq cond-indicator :~)) - (let* ((condform (pop opvals))) - (destructuring-bind (cond-name) (cdr condform) - (let* ((p (position cond-name vinsn-params))) - (if p - (if explicit-cond - (error "Can't use ~s with explicit condition name." condform) - (progn - (add-avi-operand avi (if (eq cond-indicator :?) - (encode-vinsn-field-type :cond) - (encode-vinsn-field-type :negated-cond)) - p) - (setq cond nil))) - (let* ((c (need-arm-condition-name cond-name))) - (when (eq cond-indicator :~) - (if (< c 14) - (setq c (logxor c 1)) - (error "Invalid explicit condition ~s." condform))) - (if (and explicit-cond (not (eql c cond))) - (error "Can't use explicit condition and :? : ~s" condform) - (setq cond c)))))))) - (let* ((optypes (arm-instruction-template-operand-types template)) - (n (length optypes))) - (unless (= n (length opvals)) - (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form)) - (dotimes (i n) - (let* ((optype (pop optypes)) - (opval (pop opvals))) - (funcall (svref *arm-vinsn-operand-parsers* optype) - avi opval vinsn-params))) - (when cond - (set-avi-opcode-field avi (byte 4 28) cond)) - (avi-head avi)))))) + (case name + ((:code :data) form) + (:word (destructuring-bind (val) opvals + (let* ((p (position val vinsn-params))) + (list name (if p (list p) (eval val)))))) + (t + (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name) + (unless template + (error "Unknown ARM instruction - ~s" form)) + (let* ((cond-indicator (and (consp (car opvals)) + (keywordize (caar opvals)))) + (avi (make-arm-vinsn-instruction (arm-instruction-template-val template)))) + (when (or (eq cond-indicator :?) + (eq cond-indicator :~)) + (let* ((condform (pop opvals))) + (destructuring-bind (cond-name) (cdr condform) + (let* ((p (position cond-name vinsn-params))) + (if p + (if explicit-cond + (error "Can't use ~s with explicit condition name." condform) + (progn + (add-avi-operand avi (if (eq cond-indicator :?) + (encode-vinsn-field-type :cond) + (encode-vinsn-field-type :negated-cond)) + p) + (setq cond nil))) + (let* ((c (need-arm-condition-name cond-name))) + (when (eq cond-indicator :~) + (if (< c 14) + (setq c (logxor c 1)) + (error "Invalid explicit condition ~s." condform))) + (if (and explicit-cond (not (eql c cond))) + (error "Can't use explicit condition and :? : ~s" condform) + (setq cond c)))))))) + (let* ((optypes (arm-instruction-template-operand-types template)) + (n (length optypes))) + (unless (= n (length opvals)) + (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form)) + (dotimes (i n) + (let* ((optype (pop optypes)) + (opval (pop opvals))) + (funcall (svref *arm-vinsn-operand-parsers* optype) + avi opval vinsn-params))) + (when cond + (set-avi-opcode-field avi (byte 4 28) cond)) + (avi-head avi)))))))) +(defparameter *arm-vinsn-insert-functions* + #(vinsn-insert-rd-operand + vinsn-insert-rn-operand + vinsn-insert-shifter-operand + vinsn-insert-m12-operand + vinsn-insert-reglist-operand + vinsn-insert-rnw-operand + vinsn-insert-uuoa-operand + vinsn-insert-uuo-unary-operand + vinsn-insert-uuob-operand + vinsn-insert-rm-operand + vinsn-insert-b-operand + vinsn-insert-subprim-operand + vinsn-insert-m8-operand + vinsn-insert-dd-operand + vinsn-insert-dm-operand + vinsn-insert-sd-operand + vinsn-insert-sm-operand + vinsn-insert-dn-operand + vinsn-insert-sn-operand + vinsn-insert-rde-operand + vinsn-insert-rs-operand + )) (provide "ARM-ASM") Index: /branches/arm/compiler/ARM/arm-backend.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-backend.lisp (revision 13740) +++ /branches/arm/compiler/ARM/arm-backend.lisp (revision 13741) @@ -32,9 +32,5 @@ ;;; evaluable at macroexpansion time. (defun %define-arm-vinsn (backend vinsn-name results args temps body) - (let* ((opcode-vector (backend-lap-opcodes backend)) - (opcode-lookup (backend-lookup-opcode backend)) - (opcode-expander (backend-lookup-macro backend)) - (backend-name (backend-name backend)) - (arch-name (backend-target-arch-name backend)) + (let* ((arch-name (backend-target-arch-name backend)) (template-hash (backend-p2-template-hash-name backend)) (name-list ()) @@ -98,6 +94,4 @@ (dolist (name non-hybrid-results) (add-spec-name name))) - (break) - #+notyet (let* ((k -1)) (declare (fixnum k)) @@ -169,37 +163,5 @@ (if (keywordp opname) form - (let* ((name (string opname)) - (opnum (funcall opcode-lookup name))) - (if (and (not opnum) opcode-expander) - (let* ((expander (funcall opcode-expander name))) - (if expander - (simplify-form (funcall expander form nil)) - (error "Unknown ~A instruction in ~s" backend-name form))) - (let* ((opcode (if (< -1 opnum (length opcode-vector)) - (svref opcode-vector opnum) - (error "~& Invalid ~A opcode: ~s" backend-name name))) - (opvals (mapcar #'simplify-operand opvals))) - (setf (assq opnum opcode-alist) name) - (let* ((operands (opcode-vinsn-operands opcode)) - (nmin (opcode-min-vinsn-args opcode)) - (nmax (opcode-max-vinsn-args opcode)) - (nhave (length opvals))) - (declare (fixnum nmin nmax nhave)) - (if (= nhave nmax) - `(,opnum ,@opvals) - (if (> nhave nmax) - (error "Too many operands in ~s (~a accepts at most ~d)" - (cdr w) name nmax) - (if (= nhave nmin) - (let* ((newops ())) - (dolist (op operands `(,opnum ,@(nreverse newops))) - (let* ((flags (operand-flags op))) - (unless (logbitp operand-fake flags) - (push (if (logbitp operand-optional flags) - 0 - (pop opvals)) - newops))))) - (error "Too few operands in ~s : (~a requires at least ~d)" - (cdr w) name nmin)))))))))))))) + (arm::vinsn-simplify-instruction form name-list))))))) (let* ((template (make-vinsn-template :name vinsn-name Index: /branches/arm/compiler/ARM/arm-disassemble.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-disassemble.lisp (revision 13740) +++ /branches/arm/compiler/ARM/arm-disassemble.lisp (revision 13741) @@ -28,4 +28,10 @@ (defun arm-gpr-name (regno) `(:gpr ,regno)) + +(defun arm-fprd-name (regno) + `(:double ,regno)) + +(defun arm-fprs-name (regno) + `(:single ,regno)) @@ -210,4 +216,32 @@ (if u :@+ :@-)) ,rn ,rm))))))) +(defun extract-arm-dd-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (arm-fprd-name (ldb (byte 4 12) opcode)))) + +(defun extract-arm-dm-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (arm-fprd-name (ldb (byte 4 0) opcode)))) + +(defun extract-arm-sd-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (arm-fprs-name (logior (ash (ldb (byte 4 12) opcode) 1) + (ldb (byte 1 22) opcode))))) + +(defun extract-arm-sm-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (arm-fprs-name (logior (ash (ldb (byte 4 0) opcode) 1) + (ldb (byte 1 5) opcode))))) + +(defun extract-arm-dn-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (arm-fprd-name (ldb (byte 4 16) opcode)))) + +(defun extract-arm-sn-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (arm-fprd-name (logior (ash (ldb (byte 4 16) opcode) 1) + (ldb (byte 1 7) opcode))))) + + (defparameter *arm-operand-extract-functions* #(extract-arm-rd-operand @@ -224,4 +258,10 @@ extract-arm-subprim-operand extract-arm-m8-operand + extract-arm-dd-operand + extract-arm-dm-operand + extract-arm-sd-operand + extract-arm-sm-operand + extract-arm-dn-operand + extract-arm-sn-operand )) @@ -319,4 +359,6 @@ (:? (format stream "(:? ~a)" (cadr operand))) (:gpr (format stream "~a" (svref *arm-gpr-names* (cadr operand)))) + (:single (format stream "s~d" (cadr operand))) + (:double (format stream "d~d" (cadr operand))) (:reglist (format stream "~a" (mapcar (lambda (r) Index: /branches/arm/compiler/ARM/arm-lap.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-lap.lisp (revision 13740) +++ /branches/arm/compiler/ARM/arm-lap.lisp (revision 13741) @@ -127,10 +127,10 @@ (:data (setq current (svref sections 1))) - (:text + (:code (setq current (svref sections 0))) (:section (setq current (svref sections (ecase arg - (:text 0) + (:code 0) (:data 1))))) (:word Index: /branches/arm/compiler/ARM/arm-vinsns.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-vinsns.lisp (revision 13740) +++ /branches/arm/compiler/ARM/arm-vinsns.lisp (revision 13741) @@ -48,5 +48,5 @@ ) ()) - (mov dest (:lsr idx 1)) + (mov dest (:lsr idx (:$ 1))) (add dest dest (:$ arm::misc-data-offset))) @@ -55,5 +55,5 @@ ) ()) - (mov dest (:lsr idx 2)) + (mov dest (:lsr idx (:$ 2))) (add dest dest (:$ arm::misc-data-offset))) @@ -65,4 +65,5 @@ (add dest dest (:$ arm::misc-dfloat-offset))) +#+notyet (define-arm-vinsn scale-1bit-misc-index (((word-index :u32) (bitnum :u8)) ; (unsigned-byte 5) @@ -135,18 +136,22 @@ ((v :lisp) (scaled-idx :u32)) - ()) - (lfsx dest v scaled-idx)) + ((temp :u32))) + (ldr temp (:@ v scaled-idx)) + (fmsr dest temp)) (define-arm-vinsn misc-ref-c-single-float (((dest :single-float)) ((v :lisp) (idx :u32const)) - ()) - (lfs dest (:apply + arm::misc-data-offset (:apply ash idx 2)) v)) + ((temp :u32))) + (ldr temp (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))) + (fmsr dest temp)) (define-arm-vinsn misc-ref-double-float (((dest :double-float)) ((v :lisp) (scaled-idx :u32)) - ()) - (lfdx dest v scaled-idx)) + ((low (:u32 #.arm::imm0)) + (high (:u32 #.arm::imm1)))) + (ldrd low (:@ v scaled-idx)) + (fmdrr dest low high)) @@ -154,22 +159,33 @@ ((v :lisp) (idx :u32const)) - ()) - (lfd dest (:apply + arm::misc-dfloat-offset (:apply ash idx 3)) v)) + ((low (:u32 #.arm::imm0)) + (high (:u32 #.arm::imm1)))) + (ldrd low (:@ v (:$ idx))) + (fmdrr dest low high)) (define-arm-vinsn misc-set-c-double-float (((val :double-float)) ((v :lisp) - (idx :u32const))) - (stfd val (:apply + arm::misc-dfloat-offset (:apply ash idx 3)) v)) + (idx :u32const)) + ((low (:u32 #.arm::imm0)) + (high (:u32 #.arm::imm1)))) + (fmrrd low high val) + (strd low (:@ v (:$ (:apply + arm::misc-dfloat-offset (:apply ash idx 3)))))) (define-arm-vinsn misc-set-double-float (() ((val :double-float) (v :lisp) - (scaled-idx :u32))) - (stfdx val v scaled-idx)) - -(define-arm-vinsn misc-set-c-single-float (((val :single-float)) - ((v :lisp) - (idx :u32const))) - (stfs val (:apply + arm::misc-data-offset (:apply ash idx 2)) v)) + (scaled-idx :u32)) + ((low (:u32 #.arm::imm0)) + (high (:u32 #.arm::imm1)))) + (fmrrd low high val) + (strd low (:@ v scaled-idx))) + +(define-arm-vinsn misc-set-c-single-float (() + ((val :single-float) + (v :lisp) + (idx :u32const)) + ((temp :u32))) + (fmrs temp val) + (str temp (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2)))))) @@ -178,6 +194,8 @@ ((val :single-float) (v :lisp) - (scaled-idx :u32))) - (stfsx val v scaled-idx)) + (scaled-idx :u32)) + ((temp :u32))) + (fmrs temp val) + (str temp (:@ v scaled-idx))) @@ -198,5 +216,5 @@ (idx :u32const)) ()) - (strh val (:+@ v (:apply + arm::misc-data-offset (:apply ash idx 1))))) + (strh val (:+@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1)))))) (define-arm-vinsn misc-set-u16 (((val :u16)) @@ -209,5 +227,5 @@ (scaled-idx :u32)) ()) - (lhax dest v scaled-idx)) + (ldrsh dest (:@ v scaled-idx))) (define-arm-vinsn misc-ref-c-s16 (((dest :s16)) @@ -215,5 +233,5 @@ (idx :u32const)) ()) - (lha dest (:apply + arm::misc-data-offset (:apply ash idx 1)) v)) + (ldrsh dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1)))))) @@ -222,10 +240,10 @@ (idx :u32const)) ()) - (sth val (:apply + arm::misc-data-offset (:apply ash idx 1)) v)) + (strh val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1)))))) (define-arm-vinsn misc-set-s16 (((val :s16)) ((v :lisp) (scaled-idx :s32))) - (sthx val v scaled-idx)) + (strh val (:@ v scaled-idx))) (define-arm-vinsn misc-ref-u8 (((dest :u8)) @@ -233,5 +251,5 @@ (scaled-idx :u32)) ()) - (lbzx dest v scaled-idx)) + (ldrb dest (:@ v scaled-idx))) (define-arm-vinsn misc-ref-c-u8 (((dest :u8)) @@ -239,5 +257,5 @@ (idx :u32const)) ()) - (lbz dest (:apply + arm::misc-data-offset idx) v)) + (ldrb dest (:@ v (:$ (:apply + arm::misc-data-offset idx))))) (define-arm-vinsn misc-set-c-u8 (((val :u8)) @@ -245,5 +263,5 @@ (idx :u32const)) ()) - (stb val (:apply + arm::misc-data-offset idx) v)) + (strb val (:@ v (:$ (:apply + arm::misc-data-offset idx))))) (define-arm-vinsn misc-set-u8 (((val :u8)) @@ -251,5 +269,5 @@ (scaled-idx :u32)) ()) - (stbx val v scaled-idx)) + (strb val (:@ v scaled-idx))) (define-arm-vinsn misc-ref-s8 (((dest :s8)) @@ -257,6 +275,5 @@ (scaled-idx :u32)) ()) - (lbzx dest v scaled-idx) - (extsb dest dest)) + (ldrsb dest (:@ v scaled-idx))) (define-arm-vinsn misc-ref-c-s8 (((dest :s8)) @@ -264,6 +281,5 @@ (idx :u32const)) ()) - (lbz dest (:apply + arm::misc-data-offset idx) v) - (extsb dest dest)) + (ldrsb dest (:@ v (:$ (:apply + arm::misc-data-offset idx))))) (define-arm-vinsn misc-set-c-s8 (((val :s8)) @@ -271,5 +287,5 @@ (idx :u32const)) ()) - (stb val (:apply + arm::misc-data-offset idx) v)) + (strb val (:@ v (:$ (:apply + arm::misc-data-offset idx))))) (define-arm-vinsn misc-set-s8 (((val :s8)) @@ -277,6 +293,7 @@ (scaled-idx :u32)) ()) - (stbx val v scaled-idx)) - + (strb val (:@ v scaled-idx))) + +#+notyet (define-arm-vinsn misc-ref-c-bit (((dest :u8)) ((v :lisp) @@ -286,4 +303,5 @@ (rlwinm dest dest (:apply 1+ (:apply logand idx #x1f)) 31 31)) +#+notyet (define-arm-vinsn misc-ref-c-bit-fixnum (((dest :imm)) ((v :lisp) @@ -302,5 +320,5 @@ (scaled-idx :s32)) ()) - (lwzx dest v scaled-idx)) + (ldr dest (:@ v scaled-idx))) @@ -311,5 +329,5 @@ (idx :s16const)) ()) - (lwz dest (:apply + arm::misc-data-offset (:apply ash idx 2)) v)) + (ldr dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2)))))) (define-arm-vinsn misc-set-node (() @@ -317,5 +335,5 @@ (v :lisp) (scaled-idx :u32))) - (stwx val v scaled-idx)) + (str val (:@ v scaled-idx))) ;;; This should only be used for initialization (when the value being @@ -326,5 +344,5 @@ (idx :s16const)) ()) - (stw val (:apply + arm::misc-data-offset (:apply ash idx 2)) v)) + (str val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2)))))) @@ -332,10 +350,7 @@ ((v :lisp)) ((temp :u32))) - (lwz temp arm::misc-header-offset v) - (rlwinm dest - temp - (- arm::nbits-in-word (- arm::num-subtag-bits arm::fixnumshift)) - (- arm::num-subtag-bits arm::fixnumshift) - (- arm::least-significant-bit arm::fixnumshift))) + (ldr temp (:@ v (:$ arm::misc-header-offset))) + (bic temp temp (:$ arm::subtag-mask)) + (mov dest (:lsr temp (:$ (- arm::num-subtag-bits arm::fixnum-shift))))) (define-arm-vinsn check-misc-bound (() @@ -343,11 +358,8 @@ (v :lisp)) ((temp :u32))) - (lwz temp arm::misc-header-offset v) - (rlwinm temp - temp - (- arm::nbits-in-word (- arm::num-subtag-bits arm::fixnumshift)) - (- arm::num-subtag-bits arm::fixnumshift) - (- arm::least-significant-bit arm::fixnumshift)) - (twlge idx temp)) + (ldr temp (:@ v (:$ arm::misc-header-offset))) + (bic temp temp (:$ arm::subtag-mask)) + (cmp idx (:lsr temp (:$ (- arm::num-subtag-bits arm::fixnum-shift)))) + (uuo-error-vector-bounds (:? hs) idx v)) (define-arm-vinsn 2d-unscaled-index (((dest :imm) @@ -356,8 +368,9 @@ (i :imm) (j :imm))) - (mullw dim1 i dim1) + (mul dim1 i dim1) (add dest dim1 j)) ;; dest <- (+ (* i dim1 dim2) (* j dim2) k) + (define-arm-vinsn 3d-unscaled-index (((dest :imm) (dim1 :u32) @@ -368,7 +381,7 @@ (j :imm) (k :imm))) - (mullw dim1 dim1 dim2) - (mullw dim2 j dim2) - (mullw dim1 i dim1) + (mul dim1 dim1 dim2) + (mul dim2 j dim2) + (mul dim1 i dim1) (add dim2 dim1 dim2) (add dest dim2 k)) @@ -377,14 +390,16 @@ (define-arm-vinsn 2d-dim1 (((dest :u32)) ((header :lisp))) - (lwz dest (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))) header) - (srawi dest dest arm::fixnumshift)) + (ldr dest (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell)))))) + (mov dest (:asr dest (:$ arm::fixnumshift)))) + + (define-arm-vinsn 3d-dims (((dim1 :u32) (dim2 :u32)) ((header :lisp))) - (lwz dim1 (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))) header) - (lwz dim2 (+ arm::misc-data-offset (* 4 (+ 2 arm::arrayH.dim0-cell))) header) - (srawi dim1 dim1 arm::fixnumshift) - (srawi dim2 dim2 arm::fixnumshift)) + (ldr dim1 (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell)))))) + (ldr dim2 (:@ header (:$ (+ arm::misc-data-offset (* 4 (+ 2 arm::arrayH.dim0-cell)))))) + (mov dim1 (:asr dim1 (:$ arm::fixnumshift))) + (mov dim2 (:asr dim2 (:$ arm::fixnumshift)))) ;; Return dim1 (unboxed) @@ -393,9 +408,11 @@ (j :imm) (header :lisp))) - (lwz dim (+ arm::misc-data-offset (* 4 arm::arrayH.dim0-cell)) header) - (twlge i dim) - (lwz dim (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))) header) - (twlge j dim) - (srawi dim dim arm::fixnumshift)) + (ldr dim (:@ header (:$ (+ arm::misc-data-offset (* 4 arm::arrayH.dim0-cell))))) + (cmp i dim) + (uuo-error-array-bounds (:? hs) i header) + (ldr dim (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell)))))) + (cmp j dim) + (uuo-error-array-bounds (:? hs) j header) + (mov dim (:asr dim (:$ arm::fixnumshift)))) (define-arm-vinsn check-3d-bound (((dim1 :u32) @@ -405,25 +422,31 @@ (k :imm) (header :lisp))) - (lwz dim1 (+ arm::misc-data-offset (* 4 arm::arrayH.dim0-cell)) header) - (twlge i dim1) - (lwz dim1 (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))) header) - (twlge j dim1) - (lwz dim2 (+ arm::misc-data-offset (* 4 (+ 2 arm::arrayH.dim0-cell))) header) - (twlge k dim2) - (srawi dim1 dim1 arm::fixnumshift) - (srawi dim2 dim2 arm::fixnumshift)) + (ldr dim1 (:@ header (:$ (+ arm::misc-data-offset (* 4 arm::arrayH.dim0-cell))))) + (cmp i dim1) + (uuo-error-array-bounds (:? hs) i header) + (ldr dim1 (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell)))))) + (cmp j dim1) + (uuo-error-array-bounds (:? hs) i header) + (ldr dim2 (:@ header (:$ (+ arm::misc-data-offset (* 4 (+ 2 arm::arrayH.dim0-cell)))))) + (cmp k dim2) + (uuo-error-array-bounds (:? hs) i header) + (mov dim1 (:asr dim1 (:$ arm::fixnumshift))) + (mov dim2 (:asr dim2 (:$ arm::fixnumshift)))) (define-arm-vinsn array-data-vector-ref (((dest :lisp)) ((header :lisp))) - (lwz dest arm::arrayH.data-vector header)) + (ldr dest (:@ header (:$ arm::arrayH.data-vector)))) +#+can-encode-array-rank-trap (define-arm-vinsn check-arrayH-rank (() ((header :lisp) (expected :u32const)) ((rank :imm))) - (lwz rank arm::arrayH.rank header) - (twi 27 rank (:apply ash expected arm::fixnumshift))) - + (ldr rank (:@ header (:$ arm::arrayH.rank))) + (cmp rank (:apply ash expected arm::fixnumshift)) + (uuo-error-bad-array-rank (:? ne) expected header)) + +#+can-remember-what-this-means (define-arm-vinsn check-arrayH-flags (() ((header :lisp) @@ -443,5 +466,5 @@ ((node :lisp) (cellno :u32const))) - (lwz dest (:apply + arm::misc-data-offset (:apply ash cellno 2)) node)) + (ldr dest (:@ node (:$ (:apply + arm::misc-data-offset (:apply ash cellno 2)))))) @@ -451,7 +474,8 @@ (index :lisp)) ((scaled :u32))) - (la scaled arm::misc-data-offset index) - (lwzx dest instance scaled) - (tweqi dest arm::slot-unbound-marker)) + (add scaled index (:$ arm::misc-data-offset)) + (ldr dest (:@ instance scaled)) + (cmp dest (:$ arm::slot-unbound-marker)) + (uuo-error-slot-unbound (:? eq) instance index)) @@ -461,5 +485,5 @@ ((src :address) (index :s16const))) - (lwz dest index src)) + (ldr dest (:@ src (:$ index)))) @@ -467,10 +491,10 @@ ((src :address) (index :s16const))) - (lwz dest index src)) + (ldr dest (:@ src (:$ index)))) (define-arm-vinsn mem-ref-c-natural (((dest :u32)) ((src :address) (index :s16const))) - (lwz dest index src)) + (ldr dest (:@ src (:$ index)))) @@ -478,15 +502,15 @@ ((src :address) (index :s32))) - (lwzx dest src index)) + (ldr dest (:@ src index))) (define-arm-vinsn mem-ref-signed-fullword (((dest :u32)) ((src :address) (index :s32))) - (lwzx dest src index)) + (ldr dest (:@ src index))) (define-arm-vinsn mem-ref-natural (((dest :u32)) ((src :address) (index :s32))) - (lwzx dest src index)) + (ldr dest (:@ src index))) @@ -494,5 +518,5 @@ ((src :address) (index :s16const))) - (lhz dest index src)) + (ldrh dest (:@ src (:$ index)))) @@ -500,5 +524,5 @@ ((src :address) (index :s32))) - (lhzx dest src index)) + (ldrh dest (:@ src index))) @@ -507,33 +531,32 @@ ((src :address) (index :s16const))) - (lha dest index src)) + (ldrsh dest (:@ src (:$ index)))) (define-arm-vinsn mem-ref-s16 (((dest :s16)) ((src :address) (index :s32))) - (lhax dest src index)) + (ldrsh dest (:@ src index))) (define-arm-vinsn mem-ref-c-u8 (((dest :u8)) ((src :address) (index :s16const))) - (lbz dest index src)) + (ldrb dest (:@ src (:$ index)))) (define-arm-vinsn mem-ref-u8 (((dest :u8)) ((src :address) (index :s32))) - (lbzx dest src index)) + (ldrb dest (:@ src index))) (define-arm-vinsn mem-ref-c-s8 (((dest :s8)) ((src :address) (index :s16const))) - (lbz dest index src) - (extsb dest dest)) + (ldrsb dest (:@ src (:$ index)))) (define-arm-vinsn mem-ref-s8 (((dest :s8)) ((src :address) (index :s32))) - (lbzx dest src index) - (extsb dest dest)) - + (ldrsb dest (:@ src index))) + +#+notyet (define-arm-vinsn mem-ref-c-bit (((dest :u8)) ((src :address) @@ -543,4 +566,6 @@ (rlwinm dest dest bit-shift 31 31)) + +#+notyet (define-arm-vinsn mem-ref-c-bit-fixnum (((dest :lisp)) ((src :address) @@ -551,4 +576,5 @@ (rlwinm dest byteval bit-shift 29 29)) +#+notyet (define-arm-vinsn mem-ref-bit (((dest :u8)) ((src :address) @@ -562,5 +588,5 @@ (rlwnm dest dest bit-shift 31 31)) - +#+notyet (define-arm-vinsn mem-ref-bit-fixnum (((dest :lisp)) ((src :address) @@ -580,45 +606,65 @@ (define-arm-vinsn mem-ref-c-double-float (((dest :double-float)) ((src :address) - (index :s16const))) - (lfd dest index src)) + (index :s16const)) + ((low (:u32 #.arm::imm0)) + (high (:u32 #.arm::imm1)))) + (ldrd low (:@ src (:$ index))) + (fmdrr dest low high)) (define-arm-vinsn mem-ref-double-float (((dest :double-float)) ((src :address) - (index :s32))) - (lfdx dest src index)) + (index :s32)) + ((low (:u32 #.arm::imm0)) + (high (:u32 #.arm::imm1)))) + (ldrd low (:@ src index)) + (fmdrr dest low high)) (define-arm-vinsn mem-set-c-double-float (() ((val :double-float) (src :address) - (index :s16const))) - (stfd val index src)) + (index :s16const)) + ((low (:u32 #.arm::imm0)) + (high (:u32 #.arm::imm1)))) + (fmrrd low high src) + (strd low (:@ src (:$ index)))) (define-arm-vinsn mem-set-double-float (() ((val :double-float) (src :address) - (index :s32))) - (stfdx val src index)) + (index :s32)) ; imm2, I presume + ((low (:u32 #.arm::imm0)) + (high (:u32 #.arm::imm1)))) + (fmrrd low high src) + (strd low (:@ src index))) (define-arm-vinsn mem-ref-c-single-float (((dest :single-float)) ((src :address) - (index :s16const))) - (lfs dest index src)) + (index :s16const)) + ((temp :u32))) + (ldr temp (:@ src (:$ index))) + (fmsr dest temp)) (define-arm-vinsn mem-ref-single-float (((dest :single-float)) ((src :address) - (index :s32))) - (lfsx dest src index)) + (index :s32)) + ((temp :u32))) + (ldr temp (:@ src index)) + (fmsr dest temp)) (define-arm-vinsn mem-set-c-single-float (() ((val :single-float) (src :address) - (index :s16const))) - (stfs val index src)) + (index :s16const)) + ((temp :u32))) + (fmrs temp src) + (str temp (:@ src (:$ index)))) (define-arm-vinsn mem-set-single-float (() ((val :single-float) (src :address) - (index :s32))) - (stfsx val src index)) + (index :s32)) + ((temp :u32))) + (fmrs temp src) + (str temp (:@ src (:$ index)))) @@ -627,5 +673,5 @@ (src :address) (index :s16const))) - (stw val index src)) + (str val (:@ src (:$ index)))) (define-arm-vinsn mem-set-address (() @@ -633,5 +679,5 @@ (src :address) (index :s32))) - (stwx val src index)) + (str val (:@ src index))) (define-arm-vinsn mem-set-c-fullword (() @@ -639,5 +685,5 @@ (src :address) (index :s16const))) - (stw val index src)) + (str val (:@ src (:$ index)))) (define-arm-vinsn mem-set-fullword (() @@ -645,5 +691,5 @@ (src :address) (index :s32))) - (stwx val src index)) + (str val (:@ src index))) (define-arm-vinsn mem-set-c-halfword (() @@ -651,5 +697,5 @@ (src :address) (index :s16const))) - (sth val index src)) + (strh val (:@ src (:$ index)))) (define-arm-vinsn mem-set-halfword (() @@ -657,5 +703,5 @@ (src :address) (index :s32))) - (sthx val src index)) + (strh val (:@ src index))) (define-arm-vinsn mem-set-c-byte (() @@ -663,5 +709,5 @@ (src :address) (index :s16const))) - (stb val index src)) + (strb val (:@ src (:$ index)))) (define-arm-vinsn mem-set-byte (() @@ -669,6 +715,7 @@ (src :address) (index :s32))) - (stbx val src index)) - + (strb val (:@ src index))) + +#+later (define-arm-vinsn mem-set-c-bit-0 (() ((src :address) @@ -681,4 +728,5 @@ (stb val byte-index src)) +#+later (define-arm-vinsn mem-set-c-bit-1 (() ((src :address) @@ -690,4 +738,5 @@ (stb val byte-index src)) +#+later (define-arm-vinsn mem-set-c-bit (() ((src :address) @@ -738,5 +787,5 @@ ((object :lisp))) (and tag object (:$ arm::tagmask)) - (mov tag (:lsl$ tag arm::fixnumshift))) + (mov tag (:lsl tag (:$ arm::fixnumshift)))) (define-arm-vinsn extract-fulltag (((tag :u8)) @@ -749,5 +798,5 @@ ((object :lisp))) (and tag object (:$ arm::fulltagmask)) - (mov tag (:lsl$ tag arm::fixnumshift))) + (mov tag (:lsl tag (:$ arm::fixnumshift)))) (define-arm-vinsn extract-typecode (((code :u8)) @@ -756,5 +805,5 @@ (and code object (:$ arm::tagmask)) (cmp code (:$ arm::tag-misc)) - (ldrbeq code (:@$ object arm::misc-subtag-offset))) + (ldrbeq code (:@ object (:$ arm::misc-subtag-offset)))) (define-arm-vinsn extract-typecode-fixnum (((code :imm)) @@ -763,6 +812,6 @@ (and subtag object (:$ arm::tagmask)) (cmp subtag (:$ arm::tag-misc)) - (ldrbeq subtag (:@$ object arm::misc-subtag-offset)) - (mov code (:lsl$ subtag arm::fixnumshift))) + (ldrbeq subtag (:@ object (:$ arm::misc-subtag-offset))) + (mov code (:lsl subtag (:$ arm::fixnumshift)))) @@ -781,5 +830,5 @@ (beq :got-it) (cmp tag (:$ arm::tag-misc)) - (ldrbeq tag (:+@$ object arm::misc-subtag-offset)) + (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) (cmp tag (:$ arm::subtag-bignum)) (uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::xtype-integer)) @@ -791,5 +840,5 @@ (and tag object (:$ arm::tagmask)) (cmp tag (:$ arm::tag-misc)) - (ldrbeq tag (:+@$ object arm::misc-subtag-offset)) + (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) (cmp tag (:$ arm::subtag-simple-vector)) (uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::subtag-simple-vector))) @@ -800,5 +849,5 @@ (and tag object (:$ arm::tagmask)) (cmp tag (:$ arm::tag-misc)) - (ldrbeq tag (:+@$ object arm::misc-subtag-offset)) + (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) (cmp tag (:$ arm::subtag-simple-base-string)) (uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::subtag-simple-base-string))) @@ -810,5 +859,5 @@ (and tag object (:$ arm::tagmask)) (cmp tag (:$ arm::tag-misc)) - (ldrbeq tag (:+@$ object arm::misc-subtag-offset)) + (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) (cmp tag (:$ arm::max-real-subtag)) (uuo-cerror-reg-not-xtype (:? hi) object (:$ arm::xtype-real))) @@ -819,5 +868,5 @@ (and tag object (:$ arm::tagmask)) (cmp tag (:$ arm::tag-misc)) - (ldrbeq tag (:+@$ object arm::misc-subtag-offset)) + (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) (cmp tag (:$ arm::max-numeric-subtag)) (uuo-cerror-reg-not-xtype (:? hi) object (:$ arm::xtype-number))) @@ -834,5 +883,5 @@ ((object :lisp)) ((tag :u8))) - (and tag object (:$ arm::lisptagmask)) + (and tag object (:$ arm::tagmask)) (cmp tag (:$ arm::tag-misc)) (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) @@ -853,5 +902,5 @@ ((tag :u32))) (mov tag (:lsl object (:$ (- arm::nbits-in-word (+ 8 arm::fixnumshift))))) - (mov tag (:asr tag (- arm::nbits-in-word (+ 8 arm::fixnumshift)))) + (mov tag (:asr tag (:$ (- arm::nbits-in-word (+ 8 arm::fixnumshift))))) (cmp object (:lsl tag (:$ arm::fixnumshift))) (uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::xtype-s8))) @@ -859,6 +908,8 @@ (define-arm-vinsn require-u8 (() - ((object :lisp))) - (tst object (:$ (lognot (ash #xff arm::fixnumshift)))) + ((object :lisp)) + ((temp :u32))) + (mov temp (:$ (lognot (ash #xff arm::fixnumshift)))) + (tst object temp) (uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::xtype-u8))) @@ -890,5 +941,5 @@ (ldreq header (:@ src (:$ arm::misc-header-offset))) (cmpeq tag header) - (uuo-cerror-object-not-xtype (:? ne) src (:$ arm::xtype-s32)) + (uuo-cerror-reg-not-xtype (:? ne) src (:$ arm::xtype-s32)) :got-it) @@ -898,5 +949,5 @@ ((temp :u32))) :again - (test src (:$ (logior (ash 1 (1- arm::nbits-in-word)) arm::tagmask))) + (tst src (:$ (logior (ash 1 (1- arm::nbits-in-word)) arm::tagmask))) (beq :got-it) (and temp src (:$ arm::tagmask)) @@ -905,5 +956,5 @@ (cmp temp (:$ arm::subtag-bignum)) (bne :bad-if-ne) - (ldr temp (:@ src arm::misc-header-offset)) + (ldr temp (:@ src (:$ arm::misc-header-offset))) (mov temp (:lsr temp (:$ arm::num-subtag-bits))) (cmp temp (:$ 2)) @@ -930,6 +981,6 @@ (ldreq header (:@ src (:$ arm::misc-header-offset))) (andeq tag header (:$ arm::subtag-mask)) - (cmp tag (:$ arm::subtag_bignum)) - (move header (:lsr header (:$ arm::num-subtag-bits))) + (cmp tag (:$ arm::subtag-bignum)) + (mov header (:lsr header (:$ arm::num-subtag-bits))) (bne :bad-if-ne) (cmp header (:$ 1)) @@ -949,5 +1000,5 @@ (beq :got-it) (cmp temp (:$ arm::tag-misc)) - (ldreq header (:@ src (:$ arm::misc-header-offset0))) + (ldreq header (:@ src (:$ arm::misc-header-offset))) (andeq temp src (:$ arm::subtag-mask)) (moveq header (:lsr header (:$ arm::num-subtag-bits))) @@ -1013,10 +1064,10 @@ (cmp temp (:$ arm::tag-misc)) (uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-u32)) - (ldr dest (:+@$ src arm::misc-header-offset)) - (ldr temp (:$ arm::subtag-bignum)) + (ldr dest (:@ src (:$ arm::misc-header-offset))) + (mov temp (:$ arm::subtag-bignum)) (orr temp temp (:$ (ash 1 arm::num-subtag-bits))) (cmp dest temp) (bne :maybe-two-digit) - (ldr dest (:+@$ src arm::misc-data-offset)) + (ldr dest (:@ src (:$ arm::misc-data-offset))) (tst dest (:$ 31)) (uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-u32)) @@ -1025,9 +1076,9 @@ (add temp temp (:$ (ash 1 arm::num-subtag-bits))) (cmp dest temp) - (ldreq temp (:+@$ src (+ arm::misc-data-offset 4))) + (ldreq temp (:@ src (:$ (+ arm::misc-data-offset 4)))) (cmpeq temp (:$ 0)) - (ldreq dest (:+@$ src arm::misc-data-offset)) + (ldreq dest (:@ src (:$ arm::misc-data-offset))) (uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-u32)) - :got-it)) + :got-it) ;;; an object is of type (SIGNED-BYTE 32) iff @@ -1039,14 +1090,14 @@ ((tag :u32))) (ands tag src (:$ arm::tagmask)) - (mov dest (:asr$ src arm::fixnumshift)) + (mov dest (:asr src (:$ arm::fixnumshift))) (beq :got-it) (mov dest (:$ arm::subtag-bignum)) (orr dest dest (:$ (ash 1 arm::num-subtag-bits))) (cmp tag (:$ arm::tag-misc)) - (ldreq tag (:+@ src (:$ arm::misc-header-offset))) + (ldreq tag (:@ src (:$ arm::misc-header-offset))) (cmpeq dest tag) - (ldreq dest (:+@ src (:$ arm::misc-data-offset))) + (ldreq dest (:@ src (:$ arm::misc-data-offset))) (uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-s32)) - :got-it)) + :got-it) @@ -1083,5 +1134,5 @@ ((src :lisp))) (mov dest (:lsl dest (:$ (- 24 arm::fixnumshift)))) - (mov dest (:$ asr dest (:$ 24))) + (mov dest (:asr dest (:$ 24))) (cmp src (:lsl dest (:$ arm::fixnumshift))) (uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-s8))) @@ -1092,5 +1143,5 @@ (cmp dest (:$ arm::subtag-character)) (mov dest (:lsr src (:$ arm::charcode-shift))) - (uuo-error-object-not-xtype (:? ne) src (:$ arm::subtag-character))) + (uuo-error-reg-not-xtype (:? ne) src (:$ arm::subtag-character))) @@ -1101,4 +1152,5 @@ (uuo-error-reg-not-xtype (:? hi) src (:$ arm::xtype-bit))) +#+later (define-arm-vinsn unbox-bit-bit0 (((dest :u32)) ((src :lisp)) @@ -1110,13 +1162,18 @@ :got-it) -(define-arm-vinsn fixnum->fpr (((dest :double-float)) - ((src :lisp)) - ((imm :s32))) - (stfd arm::fp-s32conv -8 arm::sp) - (srawi imm src arm::fixnumshift) - (xoris imm imm #x8000) - (stw imm -4 arm::sp) - (lfd dest -8 arm::sp) - (fsub dest dest arm::fp-s32conv)) +(define-arm-vinsn fixnum->double (((dest :double-float)) + ((src :lisp)) + ((imm :s32) + (temp :single-float))) + (mov imm (:asr src (:$ arm::fixnumshift))) + (fmsr temp imm) + (fsitod dest temp)) + +(define-arm-vinsn fixnum->single (((dest :single-float)) + ((src :lisp)) + ((imm :s32))) + (mov imm (:asr src (:$ arm::fixnumshift))) + (fmsr dest imm) + (fsitos dest dest)) @@ -1124,108 +1181,75 @@ ((src :u32) (sh :u32))) - (srw dest src sh)) + (mov dest (:lsr src sh))) (define-arm-vinsn u32logandc2 (((dest :u32)) ((x :u32) (y :u32))) - (andc dest x y)) + (bic dest x y)) (define-arm-vinsn u32logior (((dest :u32)) ((x :u32) (y :u32))) - (or dest x y)) - -(define-arm-vinsn rotate-left-variable-word (((dest :u32)) - ((src :u32) - (rot :u32))) - (rlwnm dest src rot 0 31)) + (orr dest x y)) (define-arm-vinsn complement-shift-count (((dest :u32)) ((src :u32))) - (subfic dest src 32)) + (rsb dest src (:$ 32))) (define-arm-vinsn extract-lowbyte (((dest :u32)) ((src :lisp))) - (clrlwi dest src (- arm::nbits-in-word arm::num-subtag-bits))) - -;;; Set DEST to the difference between the low byte of SRC and BYTEVAL. -(define-arm-vinsn extract-compare-lowbyte (((dest :u32)) - ((src :lisp) - (byteval :u8const))) - (clrlwi dest src (- arm::nbits-in-word arm::num-subtag-bits)) - (subi dest dest byteval)) - - -;;; Set the "EQ" bit in condition-register field CRF if object is -;;; a fixnum. Leave the object's tag in TAG. -;;; This is a little easier if CRF is CR0. -(define-arm-vinsn eq-if-fixnum (((crf :crf) - (tag :u8)) - ((object :lisp)) - ()) - ((:eq crf 0) - (clrlwi. tag object (- arm::nbits-in-word arm::nlisptagbits))) - ((:not (:eq crf 0)) - (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) - (cmpwi crf tag arm::tag-fixnum))) + (and dest src (:$ arm::subtag-mask))) + (define-arm-vinsn trap-unless-fixnum (() - ((object :lisp)) - ((tag :u8))) - (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) - (twnei tag arm::tag-fixnum)) + ((object :lisp))) + (tst object (:$ arm::fixnummask)) + (uuo-error-reg-not-lisptag (:? ne) object (:$ arm::tag-fixnum))) (define-arm-vinsn trap-unless-list (() ((object :lisp)) ((tag :u8))) - (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) - (twnei tag arm::tag-list)) + (ands tag object (:$ arm::tagmask)) + (cmp tag (:$ arm::tag-list)) + (uuo-error-reg-not-lisptag (:? ne) object (:$ arm::tag-list))) (define-arm-vinsn trap-unless-single-float (() ((object :lisp)) - ((tag :u8) - (crf :crf))) - (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) - (cmpwi crf tag arm::tag-misc) - (bne crf :do-trap) - (lbz tag arm::misc-subtag-offset object) - :do-trap - (twnei tag arm::subtag-single-float)) + ((tag :u8))) + (and tag object (:$ arm::tagmask)) + (cmp tag (:$ arm::tag-misc)) + (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) + (cmp tag (:$ arm::subtag-single-float)) + (uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-single-float))) (define-arm-vinsn trap-unless-double-float (() ((object :lisp)) - ((tag :u8) - (crf :crf))) - (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) - (cmpwi crf tag arm::tag-misc) - (bne crf :do-trap) - (lbz tag arm::misc-subtag-offset object) - :do-trap - (twnei tag arm::subtag-double-float)) + ((tag :u8))) + (and tag object (:$ arm::tagmask)) + (cmp tag (:$ arm::tag-misc)) + (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) + (cmp tag (:$ arm::subtag-double-float)) + (uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-double-float))) (define-arm-vinsn trap-unless-array-header (() ((object :lisp)) - ((tag :u8) - (crf :crf))) - (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) - (cmpwi crf tag arm::tag-misc) - (bne crf :do-trap) - (lbz tag arm::misc-subtag-offset object) - :do-trap - (twnei tag arm::subtag-arrayH)) + ((tag :u8))) + (and tag object (:$ arm::tagmask)) + (cmp tag (:$ arm::tag-misc)) + (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) + (cmp tag (:$ arm::subtag-arrayH)) + (uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-arrayH))) (define-arm-vinsn trap-unless-macptr (() ((object :lisp)) - ((tag :u8) - (crf :crf))) - (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) - (cmpwi crf tag arm::tag-misc) - (bne crf :do-trap) - (lbz tag arm::misc-subtag-offset object) - :do-trap - (twnei tag arm::subtag-macptr)) + ((tag :u8))) + (and tag object (:$ arm::tagmask)) + (cmp tag (:$ arm::tag-misc)) + (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) + (cmp tag (:$ arm::subtag-macptr)) + (uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-macptr))) @@ -1234,71 +1258,43 @@ ((object :lisp)) ((tag :u8))) - (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) - (twnei tag arm::tag-misc)) - -(define-arm-vinsn trap-unless-fulltag= (() - ((object :lisp) - (tagval :u16const)) - ((tag :u8))) - (clrlwi tag object (- arm::nbits-in-word arm::ntagbits)) - (twnei tag tagval)) - -(define-arm-vinsn trap-unless-lowbyte= (() - ((object :lisp) - (tagval :u16const)) - ((tag :u8))) - (clrlwi tag object (- arm::nbits-in-word 8)) - (twnei tag tagval)) + (and tag object (:$ arm::tagmask)) + (cmp tag (:$ arm::tag-misc)) + (uuo-error-reg-not-lisptag (:? ne) object (:$ arm::tag-misc))) + + (define-arm-vinsn trap-unless-character (() ((object :lisp)) ((tag :u8))) - (clrlwi tag object (- arm::nbits-in-word 8)) - (twnei tag arm::subtag-character)) + (and tag object (:$ arm::subtag-mask)) + (cmp tag (:$ arm::subtag-character)) + (uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-character))) (define-arm-vinsn trap-unless-cons (() ((object :lisp)) ((tag :u8))) - (clrlwi tag object (- arm::nbits-in-word arm::ntagbits)) - (twnei tag arm::fulltag-cons)) + (and tag object (:$ arm::fulltagmask)) + (cmp tag (:$ arm::fulltag-cons)) + (uuo-error-reg-not-fulltag (:? ne) object (:$ arm::fulltag-cons))) (define-arm-vinsn trap-unless-typecode= (() ((object :lisp) (tagval :u16const)) - ((tag :u8) - (crf :crf))) - (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) - (cmpwi crf tag arm::tag-misc) - (bne crf :do-trap) - (lbz tag arm::misc-subtag-offset object) - :do-trap - (twnei tag tagval)) + ((tag :u8))) + (and tag object (:$ arm::tagmask)) + (cmp tag (:$ arm::tag-misc)) + (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) + (cmp tag (:$ tagval)) + (uuo-error-reg-not-xtype (:? ne) object (:$ tagval))) (define-arm-vinsn subtract-constant (((dest :imm)) ((src :imm) (const :s16const))) - (subi dest src const)) - -(define-arm-vinsn trap-unless-numeric-type (() - ((object :lisp) - (maxtype :u16const)) - ((crf0 (:crf 0)) - (tag :u8) - (crfX :crf))) - (clrlwi. tag object (- arm::nbits-in-word arm::nlisptagbits)) - (cmpwi tag arm::tag-misc) - (beq+ crf0 :fixnum) - (bne crfX :scale-tag) - (lbz tag arm::misc-subtag-offset object) - :scale-tag - (subi tag tag arm::min-numeric-subtag) - (twlgti tag (:apply - maxtype arm::min-numeric-subtag)) - :fixnum) + (sub dest src (:$ const))) + ;; Bit-extraction & boolean operations -(eval-when (:compile-toplevel :execute) - (assert (= arm::t-offset #b10001))) ; ARM-bits 31 and 27 set ;; For some mind-numbing reason, IBM decided to call the most significant @@ -1311,4 +1307,5 @@ ;; 31.)) +#+later (define-arm-vinsn extract-variable-bit (((dest :u8)) ((src :u32) @@ -1318,5 +1315,5 @@ (extrwi dest dest 1 0)) - +#+later (define-arm-vinsn extract-variable-bit-fixnum (((dest :imm)) ((src :u32) @@ -1337,4 +1334,5 @@ ;; between T and NIL) or 0. +#+later (define-arm-vinsn lowbit->truth (((dest :lisp) (bits :u32)) @@ -1344,4 +1342,5 @@ (addi dest bits (:apply target-nil-value))) +#+later (define-arm-vinsn invert-lowbit (((bits :u32)) ((bits :u32)) @@ -1351,33 +1350,25 @@ -;; Some of the obscure-looking instruction sequences - which map some relation -;; to ARM bit 31 of some register - were found by the GNU SuperOptimizer. -;; Some of them use extended-precision instructions (which may cause interlocks -;; on some superscalar ARMs, if I remember correctly.) In general, sequences -;; that GSO found that -don't- do extended precision are longer and/or use -;; more temporaries. -;; On the 604, the penalty for using an instruction that uses the CA bit is -;; "at least" one cycle: it can't complete execution until all "older" instructions -;; have. That's not horrible, especially given that the alternative is usually -;; to use more instructions (and, more importantly, more temporaries) to avoid -;; using extended-precision. - - -(define-arm-vinsn eq0->bit31 (((bits :u32)) - ((src (t (:ne bits))))) - (cntlzw bits src) - (srwi bits bits 5)) ; bits = 0000...000X - -(define-arm-vinsn ne0->bit31 (((bits :u32)) - ((src (t (:ne bits))))) - (cntlzw bits src) - (slw bits src bits) - (srwi bits bits 31)) ; bits = 0000...000X - -(define-arm-vinsn lt0->bit31 (((bits :u32)) - ((src (t (:ne bits))))) - (srwi bits src 31)) ; bits = 0000...000X - - +(define-arm-vinsn eq0->boolean (((dest t)) + ((src t))) + (cmp src (:$ 0)) + (mov dest (:$ arm::nil-value)) + (addeq dest dest (:$ arm::t-offset))) + + +(define-arm-vinsn ne0->boolean (((dest t)) + ((src t))) + (cmp src (:$ 0)) + (mov dest (:$ arm::nil-value)) + (addne dest dest (:$ arm::t-offset))) + +(define-arm-vinsn lt0->boolean (((dest t)) + ((src t))) + (cmp src (:$ 0)) + (mov dest (:$ arm::nil-value)) + (addmi dest dest (:$ arm::t-offset))) + + +#+later (define-arm-vinsn ge0->bit31 (((bits :u32)) ((src (t (:ne bits))))) @@ -1385,5 +1376,5 @@ (xori bits bits 1)) ; bits = 0000...000X - +#+later (define-arm-vinsn le0->bit31 (((bits :u32)) ((src (t (:ne bits))))) @@ -1392,4 +1383,5 @@ (srwi bits bits 31)) ; bits = 0000...000X +#+later (define-arm-vinsn gt0->bit31 (((bits :u32)) ((src (t (:ne bits))))) @@ -1398,4 +1390,5 @@ (srwi bits bits 31)) ; bits = 0000...000X +#+later (define-arm-vinsn ne->bit31 (((bits :u32)) ((x t) @@ -1407,4 +1400,5 @@ (srwi bits bits 31)) ; bits = 0000...000X +#+later (define-arm-vinsn fulltag->bit31 (((bits :u32)) ((lispobj :lisp) @@ -1416,5 +1410,5 @@ (srwi bits bits 5)) - +#+later (define-arm-vinsn eq->bit31 (((bits :u32)) ((x t) @@ -1424,4 +1418,5 @@ (srwi bits bits 5)) ; bits = 0000...000X +#+later (define-arm-vinsn eqnil->bit31 (((bits :u32)) ((x t))) @@ -1430,4 +1425,5 @@ (srwi bits bits 5)) +#+later (define-arm-vinsn ne->bit31 (((bits :u32)) ((x t) @@ -1438,4 +1434,5 @@ (xori bits bits 1)) +#+later (define-arm-vinsn nenil->bit31 (((bits :u32)) ((x t))) @@ -1445,4 +1442,5 @@ (xori bits bits 1)) +#+later (define-arm-vinsn lt->bit31 (((bits :u32)) ((x (t (:ne bits))) @@ -1455,4 +1453,5 @@ (srwi bits bits 31)) ; bits = 0000...000X +#+later (define-arm-vinsn ltu->bit31 (((bits :u32)) ((x :u32) @@ -1462,4 +1461,5 @@ (neg bits bits)) +#+later (define-arm-vinsn le->bit31 (((bits :u32)) ((x (t (:ne bits))) @@ -1472,4 +1472,5 @@ (srwi bits bits 31)) ; bits = 0000...000X +#+later (define-arm-vinsn leu->bit31 (((bits :u32)) ((x :u32) @@ -1478,4 +1479,5 @@ (addze bits arm::rzero)) +#+later (define-arm-vinsn gt->bit31 (((bits :u32)) ((x (t (:ne bits))) @@ -1488,4 +1490,5 @@ (srwi bits bits 31)) ; bits = 0000...000X +#+later (define-arm-vinsn gtu->bit31 (((bits :u32)) ((x :u32) @@ -1495,4 +1498,5 @@ (neg bits bits)) +#+later (define-arm-vinsn ge->bit31 (((bits :u32)) ((x (t (:ne bits))) @@ -1504,4 +1508,5 @@ (srwi bits bits 31)) ; bits = 0000...000X +#+later (define-arm-vinsn geu->bit31 (((bits :u32)) ((x :u32) @@ -1517,4 +1522,5 @@ ;;; MFCR takes three cycles and waits for previous instructions to complete. ;;; Of course, using a CR field costs us something as well. +#+later (define-arm-vinsn crbit->bit31 (((bits :u32)) ((crf :crf) @@ -1525,25 +1531,26 @@ -(define-arm-vinsn compare (((crf :crf)) +(define-arm-vinsn compare (() ((arg0 t) (arg1 t)) ()) - (cmpw crf arg0 arg1)) - -(define-arm-vinsn compare-to-nil (((crf :crf)) + (cmp arg0 arg1)) + +(define-arm-vinsn compare-to-nil (() ((arg0 t))) - (cmpwi crf arg0 (:apply target-nil-value))) - -(define-arm-vinsn compare-logical (((crf :crf)) + (cmp arg0 (:$ arm::nil-value))) + +(define-arm-vinsn compare-logical ( ((arg0 t) (arg1 t)) ()) - (cmplw crf arg0 arg1)) - -(define-arm-vinsn double-float-compare (((crf :crf)) + (cmp arg0 arg1)) + +(define-arm-vinsn double-float-compare (() ((arg0 :double-float) (arg1 :double-float)) ()) - (fcmpo crf arg0 arg1)) + (fcmped arg0 arg1) + (fmstat)) @@ -1571,5 +1578,5 @@ ((x :single-float) (y :single-float)) - ((crf (:crf 4)))) + ()) (fadds result x y)) @@ -1593,21 +1600,21 @@ -(define-arm-vinsn compare-unsigned (((crf :crf)) +(define-arm-vinsn compare-unsigned (() ((arg0 :imm) (arg1 :imm)) ()) - (cmplw crf arg0 arg1)) - -(define-arm-vinsn compare-signed-s16const (((crf :crf)) + (cmp arg0 arg1)) + +(define-arm-vinsn compare-signed-s16const (() ((arg0 :imm) (imm :s16const)) ()) - (cmpwi crf arg0 imm)) - -(define-arm-vinsn compare-unsigned-u16const (((crf :crf)) + (cmp arg0 (:$ imm))) + +(define-arm-vinsn compare-unsigned-u16const (() ((arg0 :u32) (imm :u16const)) ()) - (cmplwi crf arg0 imm)) + (cmp arg0 (:$ imm))) @@ -1615,4 +1622,5 @@ ;; Extract a constant bit (0-31) from src; make it be bit 31 of dest. ;; Bitnum is treated mod 32. +#+later (define-arm-vinsn extract-constant-arm-bit (((dest :u32)) ((src :imm) @@ -1622,4 +1630,5 @@ +#+later (define-arm-vinsn set-constant-arm-bit-to-variable-value (((dest :u32)) ((src :u32) @@ -1628,4 +1637,5 @@ (rlwimi dest bitval (:apply - 32 bitnum) bitnum bitnum)) +#+later (define-arm-vinsn set-constant-arm-bit-to-1 (((dest :u32)) ((src :u32) @@ -1636,4 +1646,5 @@ (ori dest src (:apply ash #x8000 (:apply - (:apply - bitnum 16)))))) +#+later (define-arm-vinsn set-constant-arm-bit-to-0 (((dest :u32)) ((src :u32) @@ -1641,5 +1652,6 @@ (rlwinm dest src 0 (:apply logand #x1f (:apply 1+ bitnum)) (:apply logand #x1f (:apply 1- bitnum)))) - + +#+later (define-arm-vinsn insert-bit-0 (((dest :u32)) ((src :u32) @@ -1654,4 +1666,5 @@ ;;; I think ... ;;; Actually, it'd be "unbox, then subtract from 30". +#+later (define-arm-vinsn extract-variable-non-insane-bit (((dest :u32)) ((src :imm) @@ -1666,20 +1679,21 @@ (define-arm-vinsn %cdr (((dest :lisp)) ((src :lisp))) - (ldr dest (:+@$ src arm::cons.cdr))) + (ldr dest (:@ src (:$ arm::cons.cdr)))) (define-arm-vinsn %car (((dest :lisp)) ((src :lisp))) - (ldr dest (:+@$ src arm::cons.car))) + (ldr dest (:@ src (:$ arm::cons.car)))) (define-arm-vinsn %set-car (() ((cell :lisp) (new :lisp))) - (str dest (:+@$ src arm::cons.car))) + (str cell (:@ new (:$ arm::cons.car)))) (define-arm-vinsn %set-cdr (() ((cell :lisp) (new :lisp))) - (str dest (:+@$ src arm::cons.cdr))) - + (str cell (:@ new (:$ arm::cons.cdr)))) + +#+later (define-arm-vinsn load-adl (() ((n :u32const))) @@ -1689,10 +1703,10 @@ (define-arm-vinsn set-nargs (() ((n :s16const))) - (li nargs (:apply ash n arm::word-shift))) + (mov nargs (:$ (:apply ash n arm::word-shift)))) (define-arm-vinsn scale-nargs (() ((nfixed :s16const))) ((:pred > nfixed 0) - (add nargs narg (:$ (:apply - (:apply ash nfixed arm::word-shift)))))) + (add nargs nargs (:$ (:apply - (:apply ash nfixed arm::word-shift)))))) @@ -1701,10 +1715,10 @@ (() ((reg :lisp))) - (str reg (:+@! vsp (:$ (- arm::node-size))))) + (str reg (:@! vsp (:$ (- arm::node-size))))) (define-arm-vinsn (vpush-register-arg :push :node :vsp :outgoing-argument) (() ((reg :lisp))) - (str reg (:+@! vsp (:$ (- arm::node-size))))) + (str reg (:@! vsp (:$ (- arm::node-size))))) (define-arm-vinsn (vpop-register :pop :node :vsp) @@ -1734,9 +1748,9 @@ (:apply %hard-regspec-value dest) (:apply %hard-regspec-value src))) - (fmr dest src))) + (fcpyd dest src))) (define-arm-vinsn vcell-ref (((dest :lisp)) ((vcell :lisp))) - (lwz dest arm::misc-data-offset vcell)) + (ldr dest (:@ vcell (:$ arm::misc-data-offset)))) @@ -1744,44 +1758,51 @@ ((closed (:lisp :ne dest))) ((header :u32))) - (li header arm::value-cell-header) - (la arm::allocptr (- arm::fulltag-misc arm::value-cell.size) arm::allocptr) - (twllt arm::allocptr arm::allocbase) - (stw header arm::misc-header-offset arm::allocptr) - (mr dest arm::allocptr) - (clrrwi arm::allocptr arm::allocptr arm::ntagbits) - (stw closed arm::value-cell.value dest)) - -(define-arm-vinsn make-tsp-vcell (((dest :lisp)) - ((closed :lisp)) - ((header :u32))) - (li header arm::value-cell-header) - (stwu arm::tsp -16 arm::tsp) - (stw arm::tsp 4 arm::tsp) - (stfd arm::fp-zero 8 arm::tsp) - (stw arm::rzero 4 arm::tsp) - (stw header (+ 8 arm::fulltag-misc arm::value-cell.header) arm::tsp) - (stw closed (+ 8 arm::fulltag-misc arm::value-cell.value) arm::tsp) - (la dest (+ 8 arm::fulltag-misc) arm::tsp)) - -(define-arm-vinsn make-tsp-cons (((dest :lisp)) - ((car :lisp) (cdr :lisp)) - ()) - (stwu arm::tsp -16 arm::tsp) - (stw arm::tsp 4 arm::tsp) - (stfd arm::fp-zero 8 arm::tsp) - (stw arm::rzero 4 arm::tsp) - (stw car (+ 8 arm::fulltag-cons arm::cons.car) arm::tsp) - (stw cdr (+ 8 arm::fulltag-cons arm::cons.cdr) arm::tsp) - (la dest (+ 8 arm::fulltag-cons) arm::tsp)) + (mov header (:$ arm::subtag-value-cell)) + (orr header header (:$ (ash arm::value-cell.element-count arm::num-subtag-bits))) + (sub allocptr allocptr (:$ (- arm::value-cell.size arm::fulltag-misc))) + (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) + (cmp allocptr dest) + (uuo-alloc-trap (:? lo)) + (str header (:@ allocptr (:$ arm::misc-header-offset))) + (mov dest allocptr) + (bic allocptr allocptr (:$ arm::fulltagmask)) + (str closed (:@ dest (:$ arm::value-cell.value)))) + +(define-arm-vinsn make-stack-vcell (((dest :lisp)) + ((closed :lisp)) + ((header :u32))) + (mov header (:$ arm::subtag-value-cell)) + (orr header header (:$ (ash arm::value-cell.element-count arm::num-subtag-bits))) + (stmdb (:! sp) (closed header))) + +(define-arm-vinsn make-stack-cons (((dest :lisp)) + ((car :lisp) (cdr :lisp)) + ((header (:u32 #.arm::imm0)) + (zero (:u32 #.arm::imm1)))) + (mov header (:$ arm::subtag-simple-vector)) + (mov zero (:$ 0)) + (orr header header (:$ (ash 3 arm::num-subtag-bits))) + ((:pred < + (:apply %hard-regspec-value cdr) + (:apply %hard-regpsec-value car)) + (stmdb (:! sp) (car cdr zero header))) + ((:not (:pred < + (:apply %hard-regspec-value cdr) + (:apply %hard-regpsec-value car))) + (stmdb (:! sp) (cdr car zero header)) + (str car (:@ sp (:$ 12))) + (str cdr (:@ sp (:$ 8)))) + (add dest sp (:$ (+ arm::dnode-size arm::fulltag-cons)))) (define-arm-vinsn %closure-code% (((dest :lisp)) ()) - (lwz dest (:apply + arm::symbol.vcell (arm::nrs-offset %closure-code%) (:apply target-nil-value)) 0)) + (mov dest (:$ arm::nil-value)) + (ldr dest (:@ dest (:$ (:apply + arm::symbol.vcell (arm::nrs-offset %closure-code%)))))) (define-arm-vinsn single-float-bits (((dest :u32)) ((src :lisp))) - (lwz dest arm::single-float.value src)) + (ldr dest (:@ src (:$ arm::single-float.value)))) (define-arm-vinsn (call-subprim :call :subprim-call) (() @@ -1822,6 +1843,6 @@ () ((temp :u32))) - (lwz temp arm::tcr.tlb-pointer arm::rcontext) - (lwz dest arm::INTERRUPT-LEVEL-BINDING-INDEX temp)) + (ldr temp (:@ rcontext (:$ arm::tcr.tlb-pointer))) + (ldr dest (:@ temp (:$ arm::INTERRUPT-LEVEL-BINDING-INDEX)))) @@ -1887,5 +1908,5 @@ (define-arm-vinsn (discard-temp-frame :tsp :pop :discard) (() ()) - (lwz arm::tsp 0 arm::tsp)) + (ldr arm::tsp (:@ arm::tsp (:$ 0)))) @@ -1897,5 +1918,5 @@ (mov header (:$ (:apply ash (:apply + 1 (:apply logandc2 (:apply + 4 1 n-c-args) 1)) arm::num-subtag-bits))) (mov size (:lsr header (:$ (- arm::num-subtag-bits arm::word-shift)))) - (orr header (:$ arm::subtag-u32-vector)) + (orr header header (:$ arm::subtag-u32-vector)) (mov prevsp sp) (add size size (:$ arm::node-size)) @@ -1936,4 +1957,5 @@ (str argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift)))))) +#+notyet (define-arm-vinsn set-single-c-arg (() ((argval :single-float) @@ -1941,4 +1963,5 @@ (fsts argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift)))))) +#+notyet (define-arm-vinsn set-double-c-arg (() ((argval :double-float) @@ -1957,9 +1980,5 @@ (add dest dest (:$ arm::t-offset))) -(define-arm-vinsn set-eq-bit (((dest :crf)) - ()) - (creqv (:apply + arm::arm-eq-bit dest) - (:apply + arm::arm-eq-bit dest) - (:apply + arm::arm-eq-bit dest))) + (define-arm-vinsn (ref-constant :constant-ref) (((dest :lisp)) @@ -1969,16 +1988,19 @@ (define-arm-vinsn ref-indexed-constant (((dest :lisp)) ((idxreg :s32))) - (lwzx dest arm::fn idxreg)) + (ldr dest (:@ arm::fn idxreg))) (define-arm-vinsn cons (((dest :lisp)) ((newcar :lisp) - (newcdr :lisp))) - (la arm::allocptr (- arm::fulltag-cons arm::cons.size) arm::allocptr) - (twllt arm::allocptr arm::allocbase) - (stw newcdr arm::cons.cdr arm::allocptr) - (stw newcar arm::cons.car arm::allocptr) - (mr dest arm::allocptr) - (clrrwi arm::allocptr arm::allocptr arm::ntagbits)) + (newcdr :lisp)) + ((allocbase :imm))) + (sub allocptr allocptr (:$ (- arm::cons.size arm::fulltag-cons))) + (ldr allocbase (:@ rcontext (:$ arm::tcr.save-allocbase))) + (cmp allocptr allocbase) + (uuo-alloc-trap (:? lo)) + (str newcdr (:@ allocptr (:$ arm::cons.cdr))) + (str newcar (:@ allocptr (:$ arm::cons.car))) + (mov dest allocptr) + (bic allocptr allocptr (:$ arm::fulltagmask))) @@ -1989,23 +2011,34 @@ (nbytes :u32const)) ((immtemp0 :u32) - (nodetemp :lisp) - (crf :crf))) - (la arm::allocptr (:apply - arm::fulltag-misc - (:apply logand (lognot 7) - (:apply + (+ 7 4) nbytes))) - arm::allocptr) - (twllt arm::allocptr arm::allocbase) - (stw Rheader arm::misc-header-offset arm::allocptr) - (mr dest arm::allocptr) - (clrrwi arm::allocptr arm::allocptr arm::ntagbits) + (nodetemp :lisp))) + + (sub allocptr allocptr (:$ (:apply logand #xff + (:apply - + (:apply logand (lognot 7) + (:apply + (+ 7 4) nbytes)) + arm::fulltag-misc)))) + ((:pred > (:apply - + (:apply logand (lognot 7) + (:apply + (+ 7 4) nbytes)) + arm::fulltag-misc) #xff) + (sub allocptr allocptr (:$ (:apply logand #xff00 + (:apply - + (:apply logand (lognot 7) + (:apply + (+ 7 4) nbytes)) + arm::fulltag-misc))))) + (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) + (cmp allocptr dest) + (uuo-alloc-trap (:? lo)) + (str Rheader (:@ allocptr (:$ arm::misc-header-offset))) + (mov dest allocptr) + (bic allocptr allocptr (:$ arm::fulltagmask)) ((:not (:pred = nbytes 0)) - (li immtemp0 (:apply + arm::misc-data-offset nbytes)) + (mov immtemp0 (:$ (:apply + arm::misc-data-offset nbytes))) :loop - (subi immtemp0 immtemp0 4) - (cmpwi crf immtemp0 arm::misc-data-offset) - (lwz nodetemp 0 arm::vsp) - (la arm::vsp 4 arm::vsp) - (stwx nodetemp dest immtemp0) - (bne crf :loop))) + (sub immtemp0 immtemp0 (:$ 4)) + (cmp immtemp0 (:$ arm::misc-data-offset)) + (ldr nodetemp (:@+ vsp (:$ arm::node-size))) + (str nodetemp (:@ dest immtemp0)) + (bne :loop))) ;; allocate a small (phys size <= 32K bytes) misc obj of known size/subtag @@ -2013,17 +2046,28 @@ ((Rheader :u32) (nbytes :u32const))) - (la arm::allocptr (:apply - arm::fulltag-misc - (:apply logand (lognot 7) - (:apply + (+ 7 4) nbytes))) - arm::allocptr) - (twllt arm::allocptr arm::allocbase) - (stw Rheader arm::misc-header-offset arm::allocptr) - (mr dest arm::allocptr) - (clrrwi arm::allocptr arm::allocptr arm::ntagbits)) + (sub allocptr allocptr (:$ (:apply + logand #xff + (:apply - (:apply logand (lognot 7) + (:apply + (+ 7 4) nbytes)))))) + ((:pred > (:apply - + (:apply logand (lognot 7) + (:apply + (+ 7 4) nbytes)) + arm::fulltag-misc) #xff) + (sub allocptr allocptr (:$ (:apply logand #xff00 + (:apply - + (:apply logand (lognot 7) + (:apply + (+ 7 4) nbytes)) + arm::fulltag-misc))))) + (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) + (cmp allocptr dest) + (uuo-alloc-trap (:? lo)) + (str Rheader (:@ allocptr (:$ arm::misc-header-offset))) + (mov dest allocptr) + (bic allocptr allocptr (:$ arm::fulltagmask))) (define-arm-vinsn (vstack-discard :vsp :pop :discard) (() ((nwords :u32const))) ((:not (:pred = nwords 0)) - (la arm::vsp (:apply ash nwords arm::word-shift) arm::vsp))) + (add vsp vsp (:$ (:apply ash nwords arm::word-shift))))) @@ -2031,12 +2075,12 @@ ((cell :lcell) (top :lcell))) - (lwz dest (:apply - + (ldr dest (:@ vsp (:$ (:apply - (:apply - (:apply calc-lcell-depth top) 4) - (:apply calc-lcell-offset cell)) arm::vsp)) + (:apply calc-lcell-offset cell)))))) (define-arm-vinsn vframe-load (((dest :lisp)) ((frame-offset :u16const) (cur-vsp :u16const))) - (lwz dest (:apply - (:apply - cur-vsp 4) frame-offset) arm::vsp)) + (ldr dest (:@ vsp (:$ (:apply - (:apply - cur-vsp 4) frame-offset))))) (define-arm-vinsn lcell-store (() @@ -2044,7 +2088,7 @@ (cell :lcell) (top :lcell))) - (stw src (:apply - + (str src (:@ vsp (:$ (:apply - (:apply - (:apply calc-lcell-depth top) 4) - (:apply calc-lcell-offset cell)) arm::vsp)) + (:apply calc-lcell-offset cell)))))) (define-arm-vinsn vframe-store (() @@ -2052,15 +2096,15 @@ (frame-offset :u16const) (cur-vsp :u16const))) - (stw src (:apply - (:apply - cur-vsp 4) frame-offset) arm::vsp)) + (str src (:@ vsp (:$ (:apply - (:apply - cur-vsp 4) frame-offset))))) (define-arm-vinsn load-vframe-address (((dest :imm)) ((offset :s16const))) - (la dest offset arm::vsp)) + (add dest vsp (:$ offset))) (define-arm-vinsn copy-lexpr-argument (() () ((temp :lisp))) - (lwzx temp arm::vsp nargs) - (stwu temp -4 arm::vsp)) + (ldr temp (:@ vsp nargs)) + (str temp (:@! vsp (:$ (- arm::node-size))))) ;;; Boxing/unboxing of integers. @@ -2070,5 +2114,6 @@ ((val :u8)) ()) - (rlwinm result val arm::fixnumshift (- arm::nbits-in-word (+ 8 arm::fixnumshift)) (- arm::least-significant-bit arm::fixnumshift))) + (mov result (:lsr val (:$ 24))) + (mov result (:lsr val (:$ (- 24 arm::fixnumshift))))) ;;; Treat the low 8 bits of VAL as a signed integer; set RESULT to the equivalent fixnum. @@ -2076,6 +2121,6 @@ ((val :s8)) ()) - (extlwi result val 8 (- arm::nbits-in-word 8)) - (srawi result result (- (- arm::nbits-in-word 8) arm::fixnumshift))) + (mov result (:lsr val (:$ 24))) + (mov result (:asr val (:$ (- 24 arm::fixnumshift))))) @@ -2084,5 +2129,6 @@ ((val :u16)) ()) - (rlwinm result val arm::fixnumshift (- arm::nbits-in-word (+ 16 arm::fixnumshift)) (- arm::least-significant-bit arm::fixnumshift))) + (mov result (:lsl val (:$ 16))) + (mov result (:lsr result (:$ (- 16 arm::fixnumshift))))) ;;; Treat the low 16 bits of VAL as a signed integer; set RESULT to the equivalent fixnum. @@ -2108,8 +2154,8 @@ (mov temp (:$ arm::subtag-bignum)) (orr temp temp (:$ (ash 1 arm::num-subtag-bits))) - (add arm::allocptr arm::allocptr (:$ (- arm::fulltag-misc 8))) - (ldr result (:@ rcontext (:$ arm::tcr.save_allocbase))) + (add allocptr allocptr (:$ (- arm::fulltag-misc 8))) + (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase))) (cmp allocptr result) - (uuo-alloc-trap-one (:? lo)) + (uuo-alloc-trap (:? lo)) (str temp (:@ allocptr (:$ arm::misc-header-offset))) (mov result allocptr) @@ -2122,41 +2168,45 @@ (define-arm-vinsn u32->integer (((result :lisp)) ((src :u32)) - ((crf (:crf 0)) ; a casualty - (temp :s32) + ((temp :s32) (size :u32))) - (clrrwi. temp src (- arm::least-significant-bit arm::nfixnumtagbits)) - (slwi result src arm::fixnumshift) - (beq+ crf :done) - (cmpwi src 0) - (li temp arm::one-digit-bignum-header) - (li size (- 8 arm::fulltag-misc)) - (bgt :common) - (li temp arm::two-digit-bignum-header) - (li size (- 16 arm::fulltag-misc)) - :common - (sub arm::allocptr arm::allocptr size) - (twllt arm::allocptr arm::allocbase) - (stw temp arm::misc-header-offset arm::allocptr) - (mr result arm::allocptr) - (clrrwi arm::allocptr arm::allocptr arm::ntagbits) - (stw src arm::misc-data-offset result) + (tst src (:$ #xe0000000)) + (moveq result (:lsr src (:$ arm::fixnumshift))) + (beq :done) + (cmp src (:$ 0)) + (mov temp (:$ arm::subtag-bignum)) + (movgt size (:$ (- (* 2 arm::dnode-size) arm::fulltag-misc))) + (orrgt temp temp (:$ (ash 2 arm::num-subtag-bits))) + (movlt size (:$ (- (* 1 arm::dnode-size) arm::fulltag-misc))) + (orrlt temp temp (:$ (ash 1 arm::num-subtag-bits))) + (sub allocptr allocptr size) + (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase))) + (cmp allocptr result) + (uuo-alloc-trap (:? lo)) + (str temp (:@ allocptr (:$ arm::misc-header-offset))) + (mov result allocptr) + (bic allocptr allocptr (:$ arm::fulltagmask)) + (str src (:@ result (:$ arm::misc-data-offset))) :done) (define-arm-vinsn u16->u32 (((dest :u32)) ((src :u16))) - (clrlwi dest src 16)) + (mov dest (:$ #xff)) + (orr dest dest (:$ #xff00)) + (and dest dest src)) (define-arm-vinsn u8->u32 (((dest :u32)) ((src :u8))) - (clrlwi dest src 24)) + (and dest src (:$ #xff))) (define-arm-vinsn s16->s32 (((dest :s32)) ((src :s16))) - (extsh dest src)) + (mov dest (:lsl src (:$ 16))) + (mov dest (:asr src (:$ 16)))) (define-arm-vinsn s8->s32 (((dest :s32)) ((src :s8))) - (extsb dest src)) + (mov dest (:lsl src (:$ 24))) + (mov dest (:asr src (:$ 24)))) @@ -2167,12 +2217,17 @@ (define-arm-vinsn double->heap (((result :lisp)) ; tagged as a double-float ((fpreg :double-float)) - ((header-temp :u32))) - (li header-temp (arch::make-vheader arm::double-float.element-count arm::subtag-double-float)) - (la arm::allocptr (- arm::fulltag-misc arm::double-float.size) arm::allocptr) - (twllt arm::allocptr arm::allocbase) - (stw header-temp arm::misc-header-offset arm::allocptr) - (mr result arm::allocptr) - (clrrwi arm::allocptr arm::allocptr arm::ntagbits) - (stfd fpreg arm::double-float.value result) ) + ((header-temp (:u32 #.arm::imm0)) + (high (:u32 #.arm::imm1)))) + (mov header-temp (:$ arm::subtag-double-float)) + (orr header-temp header-temp (:$ (ash arm::double-float.element-count arm::num-subtag-bits))) + (sub allocptr allocptr (:$ (- arm::double-float.size arm::fulltag-misc))) + (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase))) + (cmp allocptr result) + (uuo-alloc-trap (:? lo)) + (str header-temp (:@ allocptr (:$ arm::misc-header-offset))) + (mov result allocptr) + (bic allocptr allocptr (:$ arm::fulltagmask)) + (fmrrd header-temp high fpreg) + (strd header-temp (:@ result (:$ arm::double-float.value)))) @@ -2184,11 +2239,16 @@ ((fpreg :single-float)) ((header-temp :u32))) - (li header-temp (arch::make-vheader arm::single-float.element-count arm::subtag-single-float)) - (la arm::allocptr (- arm::fulltag-misc arm::single-float.size) arm::allocptr) - (twllt arm::allocptr arm::allocbase) - (stw header-temp arm::misc-header-offset arm::allocptr) - (mr result arm::allocptr) - (clrrwi arm::allocptr arm::allocptr arm::ntagbits) - (stfs fpreg arm::single-float.value result)) + (mov header-temp (:$ arm::subtag-single-float)) + (orr header-temp header-temp (:$ (ash arm::single-float.element-count arm::num-subtag-bits))) + (sub allocptr allocptr (:$ (- arm::single-float.size arm::fulltag-misc))) + (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase))) + (cmp allocptr result) + (uuo-alloc-trap (:? lo)) + (str header-temp (:@ allocptr (:$ arm::misc-header-offset))) + (mov result allocptr) + (bic allocptr allocptr (:$ arm::fulltagmask)) + (fmrs header-temp fpreg) + (str header-temp (:@ result (:$ arm::single-float.value)))) + @@ -2197,11 +2257,15 @@ ((dest :lisp) (source :double-float)) - ()) - (stfd source arm::double-float.value dest)) + ((low (:u32 #.arm::imm0)) + (high (:u32 #.arm::imm1)))) + (fmrrd low high source) + (str low (:@ dest (:$ arm::double-float.value)))) (define-arm-vinsn get-double (((target :double-float)) ((source :lisp)) - ()) - (lfd target arm::double-float.value source)) + ((low (:u32 #.arm::imm0)) + (high (:u32 #.arm::imm1)))) + (ldrd low (:@ source (:$ arm::double-float.value))) + (fmdrr target low high)) ;;; Extract a double-float value, typechecking in the process. @@ -2211,28 +2275,31 @@ (define-arm-vinsn get-double? (((target :double-float)) ((source :lisp)) - ((tag :u8))) - (and tag source (:$ arm::tagmask)) - (cmp tag (:$ arm::tag-misc)) - (ldrbeq tag (:@ source (:$ arm::misc-subtag-offset))) - (cmp tag (:$ arm::subtag-double-float)) + ((low (:u32 #.arm::imm0)) + (high (:u32 #.arm::imm1)))) + (and low source (:$ arm::tagmask)) + (cmp low (:$ arm::tag-misc)) + (ldrbeq low (:@ source (:$ arm::misc-subtag-offset))) + (cmp imm0 (:$ arm::subtag-double-float)) (uuo-error-reg-not-xtype (:? ne) source (:$ arm::subtag-double-float)) - (ldrd imm0 imm1 (:@ source (:$ arm::double-float.value))) - (fmrrd target imm0 imm1)) + (ldrd imm0 (:@ source (:$ arm::double-float.value))) + (fmdrr target imm0 imm1)) (define-arm-vinsn double-to-single (((result :single-float)) ((arg :double-float))) - (frsp result arg)) + (fcvtsd result arg)) (define-arm-vinsn store-single (() ((dest :lisp) (source :single-float)) - ()) - (stfs source arm::single-float.value dest)) + ((temp :u32))) + (fmrs temp source) + (str temp (:@ dest (:$ arm::single-float.value)))) (define-arm-vinsn get-single (((target :single-float)) ((source :lisp)) - ()) - (lfs target arm::single-float.value source)) + ((temp :u32))) + (ldr temp (:@ source (:$ arm::single-float.value))) + (fmsr target temp)) ;;; ... of characters ... @@ -2253,18 +2320,16 @@ ((src :imm)) ((temp :u32) - (crf0 (:crf 0)))) - (srwi temp src (+ arm::fixnumshift 1)) - (cmplwi temp (ash #xffff -1)) - (srwi temp src (+ arm::fixnumshift 11)) + (temp2 :u32))) + (mov temp2 (:$ #x7f00)) + (mov temp (:lsr src (:$ (+ arm::fixnumshift 1)))) + (orr temp2 temp2 (:$ #xff)) + (cmp temp temp2) + (mov temp (:lsr src (:$ (+ arm::fixnumshift 11)))) (beq :bad) - (cmpwi temp 27) - (slwi dest src (- arm::charcode-shift arm::fixnumshift)) - (bne+ :ok) + (cmp temp (:$ 27)) + (mov dest (:lsr src (:$ (- arm::charcode-shift arm::fixnumshift)))) :bad - (li dest (:apply target-nil-value)) - (b :done) - :ok - (addi dest dest arm::subtag-character) - :done) + (moveq dest (:$ arm::nil-value)) + (addne dest dest (:$ arm::subtag-character))) ;;; src is known to be a code for which CODE-CHAR returns non-nil. @@ -2298,26 +2363,29 @@ ((address :address)) ((header :u32))) - (li header (logior (ash arm::macptr.element-count arm::num-subtag-bits) arm::subtag-macptr)) - (la arm::allocptr (- arm::fulltag-misc arm::macptr.size) arm::allocptr) - (twllt arm::allocptr arm::allocbase) - (stw header arm::misc-header-offset arm::allocptr) - (mr dest arm::allocptr) - (clrrwi arm::allocptr arm::allocptr arm::ntagbits) + (mov header (:$ arm::subtag-macptr)) + (orr header header (:$ (ash arm::macptr.element-count arm::num-subtag-bits))) + (sub allocptr allocptr (:$ (- arm::macptr.size arm::fulltag-misc))) + (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) + (cmp allocptr dest) + (uuo-alloc-trap (:? lo)) + (str header (:@ allocptr (:$ arm::misc-header-offset))) + (mov dest allocptr) + (bic allocptr allocptr (:$ arm::fulltagmask)) ;; It's not necessary to zero out the domain/type fields, since newly ;; heap-allocated memory's guaranteed to be 0-filled. - (stw address arm::macptr.address dest)) + (str address (:@ dest (:$ arm::macptr.address)))) (define-arm-vinsn macptr->stack (((dest :lisp)) ((address :address)) ((header :u32))) - (li header arm::macptr-header) - (stwu arm::tsp (- (+ 8 arm::macptr.size)) arm::tsp) - (stw arm::tsp 4 arm::tsp) - (stw header (+ 8 arm::fulltag-misc arm::macptr.header) arm::tsp) - (stw address (+ 8 arm::fulltag-misc arm::macptr.address) arm::tsp) - ;; It -is- necessary to zero out the domain/type fields here, since - ;; stack-allocated memory isn't guaranteed to be 0-filled. - (stfd arm::fp-zero (+ 8 arm::fulltag-misc arm::macptr.domain) arm::tsp) - (la dest (+ 8 arm::fulltag-misc) arm::tsp)) + (mov header (:$ arm::subtag-macptr)) + (orr header header (:$ (ash arm::macptr.element-count arm::num-subtag-bits))) + (str header (:@! sp (:$ (- arm::macptr.size)))) + (mov header (:$ 0)) + (str header (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.domain)))) + (str header (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.type)))) + (str address (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.address)))) + (add dest sp (:$ arm::fulltag-misc))) + @@ -2329,9 +2397,9 @@ (define-arm-vinsn adjust-vsp (() ((amount :s16const))) - (la arm::vsp amount arm::vsp)) + (add vsp vsp (:$ amount))) (define-arm-vinsn adjust-sp (() ((amount :s16const))) - (la arm::sp amount arm::sp)) + (add sp sp (:$ amount))) ;; Arithmetic on fixnums & unboxed numbers @@ -2353,16 +2421,18 @@ ((unboxed :s32) (header :u32))) - (nego. dest src) - (bns+ :done) - (mtxer arm::rzero) - (srawi unboxed dest arm::fixnumshift) - (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 arm::fixnumshift)))) - (li header arm::one-digit-bignum-header) - (la arm::allocptr (- arm::fulltag-misc 8) arm::allocptr) - (twllt arm::allocptr arm::allocbase) - (stw header arm::misc-header-offset arm::allocptr) - (mr dest arm::allocptr) - (clrrwi arm::allocptr arm::allocptr arm::ntagbits) - (stw unboxed arm::misc-data-offset dest) + (rsbs dest src (:$ 0)) + (bvc :done) + (mov unboxed (:asr dest (:$ arm::fixnumshift))) + (eor unboxed unboxed (:$ #xc0000000)) + (mov header (:$ arm::subtag-bignum)) + (orr header header (:$ (ash 1 arm::num-subtag-bits))) + (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc))) + (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) + (cmp allocptr dest) + (uuo-alloc-trap (:? lo)) + (str header (:@ allocptr (:$ arm::misc-header-offset))) + (mov dest allocptr) + (bic allocptr allocptr (:$ arm::fulltagmask)) + (str unboxed (:@ dest (:$ arm::misc-data-offset))) :done) @@ -2370,7 +2440,6 @@ ((src :imm)) ) - (nego. arm::arg_z src) - (bsola- .SPfix-overflow) - :done) + (rsbs arm::arg_z src (:$ 0)) + (blvs .SPfix-overflow)) @@ -2379,16 +2448,13 @@ ((src :imm))) - (neg dest src)) + (rsb dest src (:$ 0))) -(define-arm-vinsn logior-high (((dest :imm)) +(define-arm-vinsn logior-immediate (((dest :imm)) ((src :imm) - (high :u16const))) - (oris dest src high)) - -(define-arm-vinsn logior-low (((dest :imm)) - ((src :imm) - (low :u16const))) - (ori dest src low)) + (imm :u32const))) + (orr dest src (:$ imm))) + + @@ -2398,17 +2464,10 @@ (y :imm)) ()) - (or dest x y)) - -(define-arm-vinsn logand-high (((dest :imm)) + (orr dest x y)) + +(define-arm-vinsn logand-immediate (((dest :imm)) ((src :imm) - (high :u16const)) - ((crf0 (:crf 0)))) - (andis. dest src high)) - -(define-arm-vinsn logand-low (((dest :imm)) - ((src :imm) - (low :u16const)) - ((crf0 (:crf 0)))) - (andi. dest src low)) + (imm :u32const))) + (and dest src (:$ imm))) @@ -2419,26 +2478,11 @@ (and dest x y)) -(define-arm-vinsn clear-left (((dest :imm)) - ((src :imm) - (nbits :s8const))) - (rlwinm dest src 0 (:apply 1+ nbits) 31)) - -(define-arm-vinsn clear-right (((dest :imm)) - ((src :imm) - (nbits :s8const))) - (rlwinm dest src 0 0 (:apply - 31 nbits))) +(define-arm-vinsn logxor-immediate (((dest :imm)) + ((src :imm) + (imm :u32const))) + (eor dest src (:$ imm))) + -(define-arm-vinsn logxor-high (((dest :imm)) - ((src :imm) - (high :u16const))) - (xoris dest src high)) - -(define-arm-vinsn logxor-low (((dest :imm)) - ((src :imm) - (low :u16const))) - (xori dest src low)) - - (define-arm-vinsn %logxor2 (((dest :imm)) @@ -2446,23 +2490,22 @@ (y :imm)) ()) - (xor dest x y)) - + (eor dest x y)) + +;;; ARM register shifts shift by the low byte of RS. (define-arm-vinsn %ilsl (((dest :imm)) ((count :imm) (src :imm)) - ((temp :u32) - (crx :crf))) - (cmpwi crx count (ash 31 arm::fixnumshift)) - (srwi temp count arm::fixnumshift) - (slw dest src temp) - (ble+ crx :foo) - (li dest 0) - :foo) - + ((temp :u32))) + (mov temp (:asr count (:$ arm::fixnumshift))) + (mov dest (:lsl src temp))) + +;;; Shift by a constant = -> shift by 32. Don't do that. (define-arm-vinsn %ilsl-c (((dest :imm)) ((count :u8const) (src :imm))) - ; Hard to use armmacroinstructions that expand into expressions involving variables. - (rlwinm dest src count 0 (:apply - arm::least-significant-bit count))) + ((:pred = count 0) + (mov dest src)) + ((:not (:pred = count 0)) + (mov dest (:lsl src (:$ (:apply logand count 31)))))) @@ -2470,7 +2513,7 @@ ((count :u8const) (src :imm)) - (temp :s32)) + ((temp :s32))) (mov temp (:lsr src (:$ count))) - (bic test src (:$ fixnummask))) + (bic dest temp (:$ arm::fixnummask))) @@ -2479,9 +2522,7 @@ (src :imm)) ((temp :s32))) - (cmp count (:$ (ash 31 arm::fixnumshift))) (mov temp (:asr count (:$ arm::fixnumshift))) (mov temp (:asr src temp)) - (movgt temp (:asr src (:$ 31))) - (bic test temp (:$ arm::fixnummask))) + (bic dest temp (:$ arm::fixnummask))) (define-arm-vinsn %iasr-c (((dest :imm)) @@ -2489,38 +2530,44 @@ (src :imm)) ((temp :s32))) - (mov temp (:asr src (:$ count))) - (bic dest src (:$ arm::fixnummask))) + ((:pred = count 0) + (mov dest src)) + ((:not (:pred = count 0)) + (mov temp (:asr src (:$ count))) + (bic dest src (:$ arm::fixnummask)))) (define-arm-vinsn %ilsr (((dest :imm)) ((count :imm) (src :imm)) - ((temp :s32) - (crx :crf))) - (cmpwi crx count (ash 31 arm::fixnumshift)) - (srwi temp count arm::fixnumshift) - (srw temp src temp) - (clrrwi dest temp arm::fixnumshift) - (ble+ crx :foo) - (li dest 0) - :foo - ) - -#+maybe + ((temp :s32))) + (mov temp (:asr count (:$ arm::fixnumshift))) + (mov temp (:lsr src temp)) + (bic dest temp (:$ arm::fixnummask))) + + (define-arm-vinsn %ilsr-c (((dest :imm)) ((count :u8const) (src :imm)) ((temp :s32))) - (rlwinm temp src (:apply - 32 count) count 31) - (clrrwi dest temp arm::fixnumshift)) + ((:pred = count 0) + (mov dest src)) + ((:not (:pred = count 0)) + (mov temp (:lsr src (:$ count))) + (bic dest temp (:$ arm::fixnummask)))) (define-arm-vinsn natural-shift-left (((dest :u32)) ((src :u32) (count :u8const))) - (rlwinm dest src count 0 (:apply - 31 count))) + ((:pred = count 0) + (mov dest src)) + ((:not (:pred = count 0)) + (mov dest (:lsl src (:$ count))))) (define-arm-vinsn natural-shift-right (((dest :u32)) ((src :u32) (count :u8const))) - (rlwinm dest src (:apply - 32 count) count 31)) + ((:pred = count 0) + (mov dest src)) + ((:not (:pred = count 0)) + (mov dest (:lsr src (:$ count))))) @@ -2530,50 +2577,40 @@ (type-error :u8const)) ((tag :u8) - (flags :u32) - (crf :crf))) - (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) - (cmpwi crf tag arm::tag-misc) - (bne crf :bad) - (lbz tag arm::misc-subtag-offset object) - (cmpwi crf tag arm::subtag-arrayH) - (bne crf :bad) - (lwz tag arm::arrayH.rank object) - (cmpwi crf tag (ash 2 arm::fixnumshift)) - (lis tag (:apply ldb (byte 16 16) (:apply ash expected-flags arm::fixnumshift))) - - (lwz flags arm::arrayH.flags object) - (ori tag tag (:apply ldb (byte 16 0) (:apply ash expected-flags arm::fixnumshift))) - (bne crf :bad) - (cmpw crf tag flags) - (beq crf :good) - :bad - (uuo_interr type-error object) - :good) + (flags :u32))) + (and tag object (:$ arm::tagmask)) + (cmp tag (:$ arm::tag-misc)) + (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) + (cmp tag (:$ arm::subtag-arrayH)) + (bne :bad-if-ne) + (ldr tag (:@ object (:$ arm::arrayH.rank))) + (cmp tag (:$ (ash 2 arm::fixnumshift))) + (bne :bad-if-ne) + (mov tag (:$ (:apply ash (:apply logand expected-flags #xff00) arm::fixnumshift))) + (orr tag tag (:$ (:apply ash (:apply logand expected-flags #x00ff) arm::fixnumshift))) + (ldr flags (:@ object (:$ arm::arrayH.flags))) + (cmp tag flags) + :bad-if-ne + (uuo-error-reg-not-xtype (:? ne) object (:$ type-error))) (define-arm-vinsn trap-unless-simple-array-3 (() ((object :lisp) - (expected-flags :u32const) + (expected-flags :u16const) (type-error :u8const)) ((tag :u8) - (flags :u32) - (crf :crf))) - (clrlwi tag object (- arm::nbits-in-word arm::nlisptagbits)) - (cmpwi crf tag arm::tag-misc) - (bne crf :bad) - (lbz tag arm::misc-subtag-offset object) - (cmpwi crf tag arm::subtag-arrayH) - (bne crf :bad) - (lwz tag arm::arrayH.rank object) - (cmpwi crf tag (ash 3 arm::fixnumshift)) - (lis tag (:apply ldb (byte 16 16) (:apply ash expected-flags arm::fixnumshift))) - - (lwz flags arm::arrayH.flags object) - (ori tag tag (:apply ldb (byte 16 0) (:apply ash expected-flags arm::fixnumshift))) - (bne crf :bad) - (cmpw crf tag flags) - (beq crf :good) - :bad - (uuo_interr type-error object) - :good) + (flags :u32))) + (and tag object (:$ arm::tagmask)) + (cmp tag (:$ arm::tag-misc)) + (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset))) + (cmp tag (:$ arm::subtag-arrayH)) + (bne :bad-if-ne) + (ldr tag (:@ object (:$ arm::arrayH.rank))) + (cmp tag (:$ (ash 3 arm::fixnumshift))) + (bne :bad-if-ne) + (mov tag (:$ (:apply ash (:apply logand expected-flags #xff00) arm::fixnumshift))) + (orr tag tag (:$ (:apply ash (:apply logand expected-flags #x00ff) arm::fixnumshift))) + (ldr flags (:@ object (:$ arm::arrayH.flags))) + (cmp tag flags) + :bad-if-ne + (uuo-error-reg-not-xtype (:? ne) object (:$ type-error))) @@ -2582,12 +2619,7 @@ (define-arm-vinsn sign-extend-halfword (((dest :imm)) ((src :imm))) - (slwi dest src (- 16 arm::fixnumshift)) - (srawi dest dest (- 16 arm::fixnumshift))) - -(define-arm-vinsn s32-highword (((dest :imm)) - ((src :s32)) - ((temp :s32))) - (srawi temp src 16) - (slwi dest temp arm::fixnumshift)) + (mov dest (:lsl src (:$ (- 16 arm::fixnumshift)))) + (mov dest (:asr dest (:$ (- 16 arm::fixnumshift))))) + @@ -2602,26 +2634,27 @@ ((x :imm) (y :imm)) - ((cr0 (:crf 0)))) - (addo. arm::arg_z x y) - (bsola- .SPfix-overflow)) + ()) + (adds arm::arg_z x y) + (blvs .SPfix-overflow)) (define-arm-vinsn fixnum-add-overflow-inline (((dest :lisp)) ((x :imm) (y :imm)) - ((cr0 (:crf 0)) - (unboxed :s32) + ((unboxed :s32) (header :u32))) - (addo. dest x y) - (bns+ cr0 :done) - (mtxer arm::rzero) - (srawi unboxed dest arm::fixnumshift) - (li header arm::one-digit-bignum-header) - (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 arm::fixnumshift)))) - (la arm::allocptr (- arm::fulltag-misc 8) arm::allocptr) - (twllt arm::allocptr arm::allocbase) - (stw header arm::misc-header-offset arm::allocptr) - (mr dest arm::allocptr) - (clrrwi arm::allocptr arm::allocptr arm::ntagbits) - (stw unboxed arm::misc-data-offset dest) + (adds dest x y) + (bvc :done) + (mov unboxed (:asr dest (:$ arm::fixnumshift))) + (mov header (:$ arm::subtag-bignum)) + (orr header header (:$ (ash 1 arm::num-subtag-bits))) + (eor unboxed unboxed (:$ #xc0000000)) + (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc))) + (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) + (cmp allocptr dest) + (uuo-alloc-trap (:? lo)) + (str header (:@ allocptr (:$ arm::misc-header-offset))) + (mov dest allocptr) + (bic allocptr allocptr (:$ arm::fulltagmask)) + (str unboxed (:@ dest (:$ arm::misc-data-offset))) :done) @@ -2630,19 +2663,20 @@ (y :imm) (target :label)) - ((cr0 (:crf 0)) - (unboxed :s32) + ((unboxed :s32) (header :u32))) - (addo. dest x y) - (bns+ cr0 target) - (mtxer arm::rzero) - (srawi unboxed dest arm::fixnumshift) - (li header arm::one-digit-bignum-header) - (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 arm::fixnumshift)))) - (la arm::allocptr (- arm::fulltag-misc 8) arm::allocptr) - (twllt arm::allocptr arm::allocbase) - (stw header arm::misc-header-offset arm::allocptr) - (mr dest arm::allocptr) - (clrrwi arm::allocptr arm::allocptr arm::ntagbits) - (stw unboxed arm::misc-data-offset dest) + (adds dest x y) + (bvc target) + (mov unboxed (:asr dest (:$ arm::fixnumshift))) + (mov header (:$ arm::subtag-bignum)) + (orr header header (:$ (ash 1 arm::num-subtag-bits))) + (eor unboxed unboxed (:$ #xc0000000)) + (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc))) + (ldr dest (:@ rcontext (:$ arm::tcr.save-allocptr))) + (cmp allocptr dest) + (uuo-alloc-trap (:? lo)) + (str header (:@ allocptr (:$ arm::misc-header-offset))) + (mov dest allocptr) + (bic allocptr allocptr (:$ arm::fulltagmask)) + (str unboxed (:@ dest (:$ arm::misc-data-offset))) (b target)) @@ -2654,10 +2688,10 @@ ((x t) (y t))) - (subf dest y x)) + (sub dest x y)) (define-arm-vinsn fixnum-sub-from-constant (((dest :imm)) ((x :s16const) (y :imm))) - (subfic dest y (:apply ash x arm::fixnumshift))) + (rsb dest y (:$ (:apply ash x arm::fixnumshift)))) @@ -2667,6 +2701,6 @@ ((x :imm) (y :imm))) - (subo. arm::arg_z x y) - (bsola- .SPfix-overflow)) + (subs arm::arg_z x y) + (blvs .SPfix-overflow)) (define-arm-vinsn fixnum-sub-overflow-inline (((dest :lisp)) @@ -2676,16 +2710,18 @@ (unboxed :s32) (header :u32))) - (subo. dest x y) - (bns+ cr0 :done) - (mtxer arm::rzero) - (srawi unboxed dest arm::fixnumshift) - (li header arm::one-digit-bignum-header) - (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 arm::fixnumshift)))) - (la arm::allocptr (- arm::fulltag-misc 8) arm::allocptr) - (twllt arm::allocptr arm::allocbase) - (stw header arm::misc-header-offset arm::allocptr) - (mr dest arm::allocptr) - (clrrwi arm::allocptr arm::allocptr arm::ntagbits) - (stw unboxed arm::misc-data-offset dest) + (subs dest x y) + (bvc :done) + (mov unboxed (:asr dest (:$ arm::fixnumshift))) + (mov header (:$ arm::subtag-bignum)) + (orr header header (:$ (ash 1 arm::num-subtag-bits))) + (eor unboxed unboxed (:$ #xc0000000)) + (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc))) + (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) + (cmp allocptr dest) + (uuo-alloc-trap (:? lo)) + (str header (:@ allocptr (:$ arm::misc-header-offset))) + (mov dest allocptr) + (bic allocptr allocptr (:$ arm::fulltagmask)) + (str unboxed (:@ dest (:$ arm::misc-data-offset))) :done) @@ -2694,19 +2730,20 @@ (y :imm) (target :label)) - ((cr0 (:crf 0)) - (unboxed :s32) + ((unboxed :s32) (header :u32))) - (subo. dest x y) - (bns+ cr0 target) - (mtxer arm::rzero) - (srawi unboxed dest arm::fixnumshift) - (li header arm::one-digit-bignum-header) - (xoris unboxed unboxed (logand #xffff (ash #xffff (- 32 16 arm::fixnumshift)))) - (la arm::allocptr (- arm::fulltag-misc 8) arm::allocptr) - (twllt arm::allocptr arm::allocbase) - (stw header arm::misc-header-offset arm::allocptr) - (mr dest arm::allocptr) - (clrrwi arm::allocptr arm::allocptr arm::ntagbits) - (stw unboxed arm::misc-data-offset dest) + (subs dest x y) + (bvc target) + (mov unboxed (:asr dest (:$ arm::fixnumshift0))) + (mov header (:$ arm::subtag-bignum)) + (orr header header (:$ (ash 1 arm::num-subtag-bits))) + (eor unboxed unboxed (:$ #xc0000000)) + (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc))) + (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) + (cmp allocptr dest) + (uuo-alloc-trap (:? lo)) + (str header (:@ allocptr (:$ arm::misc-header-offset))) + (mov dest allocptr) + (bic allocptr allocptr (:$ arm::fulltagmask)) + (str unboxed (:@ dest (:$ arm::misc-data-offset))) (b target)) @@ -2714,26 +2751,15 @@ (define-arm-vinsn add-immediate (((dest t)) ((src t) - (upper :u32const) - (lower :u32const))) - ((:not (:pred = upper 0)) - (addis dest src upper) - ((:not (:pred = lower 0)) - (addi dest dest lower))) - ((:and (:pred = upper 0) (:not (:pred = lower 0))) - (addi dest src lower))) - -;This must unbox one reg, but hard to tell which is better. -;(The one with the smaller absolute value might be) + (imm :s32const))) + (add dest src (:$ imm))) + (define-arm-vinsn multiply-fixnums (((dest :imm)) ((a :imm) (b :imm)) ((unboxed :s32))) - (srawi unboxed b arm::fixnumshift) - (mullw dest a unboxed)) - -(define-arm-vinsn multiply-immediate (((dest :imm)) - ((boxed :imm) - (const :s16const))) - (mulli dest boxed const)) + (mov unboxed (:asr b (:$ arm::fixnumshift))) + (mul dest a unboxed)) + + ;;; Mask out the code field of a base character; the result @@ -2741,5 +2767,5 @@ (define-arm-vinsn mask-base-char (((dest :u32)) ((src :imm))) - (clrlwi dest src (- arm::nbits-in-word arm::charcode-shift))) + (and dest src (:$ arm::subtag-mask))) ;;; Set dest (of type :s32!) to 0 iff VAL is an istruct of type TYPE @@ -2747,16 +2773,12 @@ ((val :lisp) (type :lisp)) - ((crf :crf) - (temp :lisp))) - (clrlwi dest val (- arm::nbits-in-word arm::nlisptagbits)) - (cmpwi crf dest arm::tag-misc) - (li dest -1) - (bne crf :done) - (lbz dest arm::misc-subtag-offset val) - (cmpwi crf dest arm::subtag-istruct) - (bne crf :done) - (lwz temp arm::misc-data-offset val) - (subf dest type temp) - :done) + ((temp :lisp))) + (and dest val (:$ arm::tagmask)) + (cmp dest (:$ arm::tag-misc)) + (ldrbeq dest (:@ val (:$ arm::misc-subtag-offset))) + (cmp dest (:$ arm::subtag-istruct)) + (movne dest (:$ -1)) + (ldreq temp (:@ val (:$ arm::misc-data-offset))) + (subeq dest type temp)) @@ -2771,16 +2793,14 @@ ((table :imm) (idx :imm))) - (lwz idx arm::symbol.binding-index src) - (lwz table arm::tcr.tlb-limit arm::rcontext) - (cmpw idx table) - (lwz table arm::tcr.tlb-pointer arm::rcontext) - (bge :symbol) - (lwzx dest table idx) - (cmpwi dest arm::subtag-no-thread-local-binding) - (bne :done) - :symbol - (lwz dest arm::symbol.vcell src) - :done - (tweqi dest arm::unbound-marker)) + (ldr idx (:@ src (:$ arm::symbol.binding-index))) + (ldr table (:@ rcontext (:$ arm::tcr.tlb-limit))) + (cmp idx table) + (ldr table (:@ rcontext (:$ arm::tcr.tlb-pointer))) + (movhs idx (:$ 0)) + (ldr dest (:@ table idx)) + (cmp dest (:$ arm::subtag-no-thread-local-binding)) + (ldreq dest (:@ src (:$ arm::symbol.vcell))) + (cmp dest (:$ arm::unbound-marker)) + (uuo-error-unbound (:? eq) src)) (define-arm-vinsn (%ref-symbol-value :call :subprim-call) @@ -2793,16 +2813,12 @@ ((table :imm) (idx :imm))) - (lwz idx arm::symbol.binding-index src) - (lwz table arm::tcr.tlb-limit arm::rcontext) - (cmpw idx table) - (lwz table arm::tcr.tlb-pointer arm::rcontext) - (bge :symbol) - (lwzx dest table idx) - (cmpwi dest arm::subtag-no-thread-local-binding) - (bne :done) - :symbol - (lwz dest arm::symbol.vcell src) - :done - ) + (ldr idx (:@ src (:$ arm::symbol.binding-index))) + (ldr table (:@ rcontext (:$ arm::tcr.tlb-limit))) + (cmp idx table) + (ldr table (:@ rcontext (:$ arm::tcr.tlb-pointer))) + (movhs idx (:$ 0)) + (ldr dest (:@ table idx)) + (cmp dest (:$ arm::subtag-no-thread-local-binding)) + (ldreq dest (:@ src (:$ arm::symbol.vcell)))) (define-arm-vinsn (setq-special :call :subprim-call) @@ -2817,14 +2833,10 @@ ((crf :crf) (tag :u32))) - (lwz val arm::symbol.fcell sym) - (clrlwi tag val (- 32 arm::nlisptagbits)) - (cmpwi crf tag arm::tag-misc) - (bne- crf :bad) - (lbz tag arm::misc-subtag-offset val) - (cmpwi crf tag arm::subtag-function) - (beq+ crf :good) - :bad - (uuo_interr arch::error-udf sym) - :good) + (ldr val (:@ sym (:$ arm::symbol.fcell))) + (and tag val (:$ arm::tagmask)) + (cmp tag (:$ arm::tag-misc)) + (ldrbeq tag (:@ val (:$ arm::misc-subtag-offset))) + (cmp tag (:$ arm::subtag-function)) + (uuo-error-udf (:? ne) sym)) (define-arm-vinsn (temp-push-unboxed-word :push :word :sp) @@ -2835,5 +2847,5 @@ (orr header header (:$ (ash 1 arm::num-subtag-bits))) (str header (:@ sp (:$ (- arm::dnode-size)))) - (str w (:@ sp 4))) + (str w (:@ sp (:$ 4)))) (define-arm-vinsn (temp-pop-unboxed-word :pop :word :sp) @@ -2843,4 +2855,5 @@ (add sp sp (:$ arm::dnode-size))) +#+notyet (define-arm-vinsn (temp-push-double-float :push :doubleword :sp) (() @@ -2852,4 +2865,5 @@ (fstd d (:@ sp (:$ 8)))) +#+notyet (define-arm-vinsn (temp-pop-double-float :pop :doubleword :sp) (() @@ -2858,4 +2872,5 @@ (add sp sp (:$ (* 2 arm::dnode-size)))) +#+notyet (define-arm-vinsn (temp-push-single-float :push :word :tsp) (() @@ -2867,4 +2882,5 @@ (fsts s (:@ sp (:$ 4)))) +#+notyet (define-arm-vinsn (temp-pop-single-float :pop :word :sp) (() @@ -2881,5 +2897,5 @@ (define-arm-vinsn %current-tcr (((dest :imm)) ()) - (mov dest arm::rcontext)) + (mov dest rcontext)) (define-arm-vinsn (dpayback :call :subprim-call) (() @@ -2893,10 +2909,14 @@ (define-arm-vinsn zero-double-float-register (((dest :double-float)) - ()) - (fmr dest arm::fp-zero)) + () + ((temp t))) + (mov temp (:$ 0)) + (fmsr dest temp)) (define-arm-vinsn zero-single-float-register (((dest :single-float)) - ()) - (fmr dest arm::fp-zero)) + () + ((temp t))) + (mov temp (:$ 0)) + (fmdrr dest temp temp)) (define-arm-vinsn load-double-float-constant (((dest :double-float)) @@ -2917,10 +2937,10 @@ ((n :u16const))) (cmp nargs (:$ (:apply ash n 2))) - (uuo-error-wrong-nargs (:ne))) + (uuo-error-wrong-nargs (:? ne))) (define-arm-vinsn check-min-nargs (() ((min :u16const))) (cmp nargs (:$ (:apply ash min 2))) - (uuo-error-wrong-nargs (:lo))) + (uuo-error-wrong-nargs (:? lo))) @@ -2928,5 +2948,5 @@ ((max :u16const))) (cmp nargs (:$ (:apply ash max 2))) - (uuo-error-wrong-nargs (:hi))) + (uuo-error-wrong-nargs (:? hi))) ;;; Save context and establish FN. The current VSP is the the @@ -2936,5 +2956,6 @@ ((imm :u32))) (mov imm (:$ arm::lisp-frame-marker)) - (stmdb (:! sp) (imm vsp fn lr))) + (stmdb (:! sp) (imm vsp fn lr)) + (mov fn nfn)) @@ -2945,5 +2966,6 @@ (add imm vsp (:$ nbytes-vpushed)) (mov imm0 (:$ arm::lisp-frame-marker)) - (stmdb (:! sp) (imm0 imm fn lr))) + (stmdb (:! sp) (imm0 imm fn lr)) + (mov fn nfn)) @@ -2954,10 +2976,10 @@ ((imm :u32))) (stwu arm::sp (- arm::lisp-frame.size) arm::sp) - (stw arm::rzero arm::lisp-frame.savefn arm::sp) - (stw arm::loc-pc arm::lisp-frame.savelr arm::sp) - (stw arm::vsp arm::lisp-frame.savevsp arm::sp) + (str arm::rzero (:@ arm::sp (:$ arm::lisp-frame.savefn))) + (str arm::loc-pc (:@ arm::sp (:$ arm::lisp-frame.savelr))) + (str vsp (:@ arm::sp (:$ arm::lisp-frame.savevsp))) (mr arm::fn arm::nfn) ;; Do a stack-probe ... - (lwz imm arm::tcr.cs-limit arm::rcontext) + (ldr imm (:@ rcontext (:$ arm::tcr.cs-limit))) (twllt arm::sp imm)) @@ -2980,23 +3002,23 @@ (arg-temp :u32))) ((:pred >= min-fixed $numarmargregs) - (stwu arm::arg_x -4 arm::vsp) - (stwu arm::arg_y -4 arm::vsp) - (stwu arm::arg_z -4 arm::vsp)) + (stwu arm::arg_x -4 vsp) + (stwu arm::arg_y -4 vsp) + (stwu arm::arg_z -4 vsp)) ((:pred = min-fixed 2) ; at least 2 args (cmplwi crfx nargs (ash 2 arm::word-shift)) (beq crfx :yz2) ; skip arg_x if exactly 2 - (stwu arm::arg_x -4 arm::vsp) + (stwu arm::arg_x -4 vsp) :yz2 - (stwu arm::arg_y -4 arm::vsp) - (stwu arm::arg_z -4 arm::vsp)) + (stwu arm::arg_y -4 vsp) + (stwu arm::arg_z -4 vsp)) ((:pred = min-fixed 1) ; at least one arg (cmplwi crfx nargs (ash 2 arm::word-shift)) (blt crfx :z1) ; branch if exactly one (beq crfx :yz1) ; branch if exactly two - (stwu arm::arg_x -4 arm::vsp) + (stwu arm::arg_x -4 vsp) :yz1 - (stwu arm::arg_y -4 arm::vsp) + (stwu arm::arg_y -4 vsp) :z1 - (stwu arm::arg_z -4 arm::vsp)) + (stwu arm::arg_z -4 vsp)) ((:pred = min-fixed 0) (cmplwi crfx nargs (ash 2 arm::word-shift)) @@ -3006,17 +3028,17 @@ (blt crfx :z0) ; one ; Three or more ... - (stwu arm::arg_x -4 arm::vsp) + (stwu arm::arg_x -4 vsp) :yz0 - (stwu arm::arg_y -4 arm::vsp) + (stwu arm::arg_y -4 vsp) :z0 - (stwu arm::arg_z -4 arm::vsp) + (stwu arm::arg_z -4 vsp) :none ) ((:pred = min-fixed 0) - (stwu nargs -4 arm::vsp)) + (stwu nargs -4 vsp)) ((:not (:pred = min-fixed 0)) (subi arg-temp nargs (:apply ash min-fixed arm::word-shift)) - (stwu arg-temp -4 arm::vsp)) - (add entry-vsp arm::vsp nargs) + (stwu arg-temp -4 vsp)) + (add entry-vsp vsp nargs) (la entry-vsp 4 entry-vsp) (bl .SPlexpr-entry)) @@ -3046,5 +3068,5 @@ (define-arm-vinsn restore-cleanup-context (() ()) - (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)) + (ldr lr (:@ sp (:$ arm::lisp-frame.savelr))) (add sp sp (:$ arm::lisp-frame.size))) @@ -3056,15 +3078,15 @@ (bne :done) ((:pred >= min 3) - (str arg_x (:@! vsp (:$ (- arm::node-size)))) + (str arg_x (:@! vsp (:$ (- arm::node-size))))) ((:pred >= min 2) (mov arg_x arg_y)) ((:pred >= min 1) (mov arg_y arg_z)) - (move arm::arg_z (:$ arm::nil-value)) + (mov arm::arg_z (:$ arm::nil-value)) :done) (define-arm-vinsn default-2-args (() ((min :u16const))) - (cmp nargs (:apply ash (:apply 1+ min) 2)) + (cmp nargs (:$ (:apply ash (:apply 1+ min) 2))) (bgt :done) (beq :one) @@ -3083,6 +3105,6 @@ (str arg_x (:@! vsp (:$ (- arm::node-size))))) ((:pred >= min 1) - (move arg_x arg_y)) - (mr arm::arg_y arm::arg_z) + (mov arg_x arg_y)) + (mov arm::arg_y arm::arg_z) :last (mov arg_z (:$ arm::nil-value)) @@ -3160,5 +3182,5 @@ (idx :imm)) ((imm :u32))) - (mov imm (:$ lsr idx (:$ arm::fixnumshift))) + (mov imm (:lsr idx (:$ arm::fixnumshift))) (add imm imm (:$ arm::misc-data-offset)) (ldrb imm (:@ str imm)) @@ -3182,7 +3204,7 @@ ((imm :u32) (imm1 :u32))) - (mov imm (:lsr (:$ idx arm::fixnumshift))) + (mov imm (:lsr idx (:$ arm::fixnumshift))) (add imm imm (:$ arm::misc-data-offset)) - (mov imm1 (:lst char (:$ arm::charcode-shift))) + (mov imm1 (:lsr char (:$ arm::charcode-shift))) (strb imm1 (:@ str imm))) @@ -3215,38 +3237,35 @@ ((imm :u32) (imm1 :u32))) - (addi imm idx arm::misc-data-offset) - (srwi imm1 code arm::fixnumshift) - (stwx imm1 str imm) - ) + (add imm idx (:$ arm::misc-data-offset)) + (mov imm1 (:lsr code (:$ arm::fixnumshift))) + (str imm1 (:@ str imm))) (define-arm-vinsn %scharcode8 (((code :imm)) ((str :lisp) (idx :imm)) - ((imm :u32) - (cr0 (:crf 0)))) - (srwi imm idx arm::fixnumshift) - (addi imm imm arm::misc-data-offset) - (lbzx imm str imm) - (slwi code imm arm::fixnumshift)) + ((imm :u32))) + (mov imm (:lsr idx (:$ arm::fixnumshift))) + (add imm imm (:$ arm::misc-data-offset)) + (ldrb imm (:@ str imm)) + (mov code (:lsl imm (:$ arm::fixnumshift)))) (define-arm-vinsn %scharcode32 (((code :imm)) ((str :lisp) (idx :imm)) - ((imm :u32) - (cr0 (:crf 0)))) - (addi imm idx arm::misc-data-offset) - (lwzx imm str imm) - (slwi code imm arm::fixnumshift)) + ((imm :u32))) + (add imm idx (:$ arm::misc-data-offset)) + (ldr imm (:@ str imm)) + (mov code (:lsl imm (:$ arm::fixnumshift)))) ;;; Clobbers LR -(define-arm-vinsn (%debug-trap :call :subprim-call) (() +(define-arm-vinsn %debug-trap (() ()) - (bl .SPbreakpoint) - ) - - + (uuo-debug-trap)) + + +#+notyet (define-arm-vinsn eep.address (((dest t)) ((src (:lisp (:ne dest ))))) - (lwz dest (+ (ash 1 2) arm::misc-data-offset) src) + (ldr dest (:@ src (:$ (+ (ash 1 2) arm::misc-data-offset)))) (tweqi dest (:apply target-nil-value))) @@ -3257,5 +3276,5 @@ (define-arm-vinsn %natural+-c (((dest :u32)) ((x :u32) (y :u16const))) - (addi dest x y)) + (add dest x (:$ y))) (define-arm-vinsn %natural- (((dest :u32)) @@ -3265,27 +3284,21 @@ (define-arm-vinsn %natural--c (((dest :u32)) ((x :u32) (y :u16const))) - (subi dest x y)) + (sub dest x (:$ y))) (define-arm-vinsn %natural-logior (((dest :u32)) ((x :u32) (y :u32))) - (or dest x y)) + (orr dest x y)) (define-arm-vinsn %natural-logior-c (((dest :u32)) - ((x :u32) (high :u16const) (low :u16const))) - ((:not (:pred = high 0)) - (oris dest x high)) - ((:not (:pred = low 0)) - (ori dest x low))) + ((x :u32) (c :u32const))) + (orr dest x (:$ c))) (define-arm-vinsn %natural-logxor (((dest :u32)) ((x :u32) (y :u32))) - (xor dest x y)) + (eor dest x y)) (define-arm-vinsn %natural-logxor-c (((dest :u32)) - ((x :u32) (high :u16const) (low :u16const))) - ((:not (:pred = high 0)) - (xoris dest x high)) - ((:not (:pred = low 0)) - (xori dest x low))) + ((x :u32) (c :u32const))) + (eor dest x (:$ c))) (define-arm-vinsn %natural-logand (((dest :u32)) @@ -3293,19 +3306,13 @@ (and dest x y)) -(define-arm-vinsn %natural-logand-high-c (((dest :u32)) - ((x :u32) (high :u16const)) - ((cr0 (:crf 0)))) - (andis. dest x high)) - -(define-arm-vinsn %natural-logand-low-c (((dest :u64)) - ((x :u64) (low :u16const)) - ((cr0 (:crf 0)))) - (andi. dest x low)) - -(define-arm-vinsn %natural-logand-mask-c (((dest :u32)) - ((x :u32) - (start :u8const) - (end :u8const))) - (rlwinm dest x 0 start end)) +(define-arm-vinsn %natural-logand-c (((dest :u32)) + ((x :u32) (c :u16const)) + ) + (and dest x (:$ c))) + + + + + (define-arm-vinsn disable-interrupts (((dest :lisp)) @@ -3313,14 +3320,18 @@ ((temp :imm) (temp2 :imm))) - (lwz temp2 arm::tcr.tlb-pointer arm::rcontext) - (li temp -4) - (lwz dest arm::interrupt-level-binding-index temp2) - (stw temp arm::interrupt-level-binding-index temp2)) + (ldr temp2 (:@ rcontext (:$ arm::tcr.tlb-pointer))) + (mov temp (:$ -4)) + (ldr dest (:@ temp2 (:$ arm::interrupt-level-binding-index))) + (str temp (:@ temp2 (:$ arm::interrupt-level-binding-index)))) (define-arm-vinsn load-character-constant (((dest :lisp)) ((code :u32const))) - (ori dest arm::rzero (:apply logior (:apply ash (:apply logand #xff code) arm::charcode-shift) arm::subtag-character)) - ((:not (:pred = 0 (:apply ldb (byte 16 8) code))) - (oris dest dest (:apply ldb (byte 16 8) code)))) + (mov dest (:$ arm::subtag-character)) + ((:pred logtest #xff code) + (orr dest dest (:$ (:apply ash (:apply logand code #xff) 8)))) + ((:pred logtest #xff00 code) + (orr dest dest (:$ (:apply ash (:apply ldb (byte 8 8) code) 16)))) + ((:pred logtest #xff000 code) + (orr dest dest (:$ (:apply ash (:apply ldb (byte 8 16) code) 24))))) @@ -3338,5 +3349,5 @@ (:apply %hard-regspec-value dest) (:apply %hard-regspec-value src))) - (mr dest src)) + (mov dest src)) (b :done) :nilsym @@ -3533,4 +3544,5 @@ (define-arm-subprim-call-vinsn (bind-interrupt-level-0) .SPbind-interrupt-level-0) +#+notyet (define-arm-vinsn bind-interrupt-level-0-inline (() () @@ -3539,18 +3551,18 @@ (link :imm) (temp :imm))) - (lwz tlb arm::tcr.tlb-pointer arm::rcontext) - (lwz value arm::interrupt-level-binding-index tlb) - (lwz link arm::tcr.db-link arm::rcontext) + (ldr tlb (:@ rcontext (:$ arm::tcr.tlb-pointer))) + (ldr value (:@ tlb (:$ arm::interrupt-level-binding-index))) + (ldr link (:@ rcontext (:$ arm::tcr.db-link))) (cmpwi value 0) (li temp arm::interrupt-level-binding-index) - (stwu value -4 arm::vsp) - (stwu temp -4 arm::vsp) - (stwu link -4 arm::vsp) - (stw arm::rzero arm::interrupt-level-binding-index tlb) - (stw arm::vsp arm::tcr.db-link arm::rcontext) + (stwu value -4 vsp) + (stwu temp -4 vsp) + (stwu link -4 vsp) + (str arm::rzero (:@ tlb (:$ arm::interrupt-level-binding-index))) + (str vsp (:@ rcontext (:$ arm::tcr.db-link))) (beq+ :done) (mr nargs value) (bgt :do-trap) - (lwz nargs arm::tcr.interrupt-pending arm::rcontext) + (ldr nargs (:@ rcontext (:$ arm::tcr.interrupt-pending))) :do-trap (twgti nargs 0) @@ -3568,15 +3580,14 @@ (newvalue :imm) (idx :imm))) - (li newvalue (ash -1 arm::fixnumshift)) - (li idx arm::interrupt-level-binding-index) - (lwz tlb arm::tcr.tlb-pointer arm::rcontext) - (lwz oldvalue arm::interrupt-level-binding-index tlb) - (lwz link arm::tcr.db-link arm::rcontext) - (stwu oldvalue -4 arm::vsp) - (stwu idx -4 arm::vsp) - (stwu link -4 arm::vsp) - (stw newvalue arm::interrupt-level-binding-index tlb) - (stw arm::vsp arm::tcr.db-link arm::rcontext) - :done) + (mov newvalue (:$ (ash -1 arm::fixnumshift))) + (mov idx (:$ arm::interrupt-level-binding-index)) + (ldr tlb (:@ rcontext (:$ arm::tcr.tlb-pointer))) + (ldr oldvalue (:@ tlb (:$ arm::interrupt-level-binding-index))) + (ldr link (:@ rcontext (:$ arm::tcr.db-link))) + (str oldvalue (:@! vsp (:$ (- arm::node-size)))) + (str idx (:@! vsp (:$ (- arm::node-size)))) + (str link (:@! vsp (:$ (- arm::node-size)))) + (str newvalue (:@ tlb (:$ arm::interrupt-level-binding-index))) + (str vsp (:@ rcontext (:$ arm::tcr.db-link)))) (define-arm-subprim-call-vinsn (bind-interrupt-level) .SPbind-interrupt-level) @@ -3584,4 +3595,5 @@ (define-arm-subprim-call-vinsn (unbind-interrupt-level) .SPunbind-interrupt-level) +#+notyet (define-arm-vinsn unbind-interrupt-level-inline (() () @@ -3592,17 +3604,17 @@ (crf0 :crf) (crf1 :crf))) - (lwz tlb arm::tcr.tlb-pointer arm::rcontext) - (lwz value arm::interrupt-level-binding-index tlb) - (lwz link arm::tcr.db-link arm::rcontext) + (ldr tlb (:@ rcontext (:$ arm::tcr.tlb-pointer))) + (ldr value (:@ tlb (:$ arm::interrupt-level-binding-index))) + (ldr link (:@ rcontext (:$ arm::tcr.db-link))) (cmpwi crf1 value 0) - (lwz value 8 link) - (lwz link 0 link) + (ldr value (:@ link (:$ 8))) + (ldr link (:@ link (:$ 0))) (cmpwi crf0 value 0) - (stw value arm::interrupt-level-binding-index tlb) - (stw link arm::tcr.db-link arm::rcontext) + (str value (:@ tlb (:$ arm::interrupt-level-binding-index))) + (str link (:@ rcontext (:$ arm::tcr.db-link))) (bge crf1 :done) (blt crf0 :done) (mr save-nargs nargs) - (lwz nargs arm::tcr.interrupt-pending arm::rcontext) + (ldr nargs (:@ rcontext (:$ arm::tcr.interrupt-pending))) (twgti nargs 0) (mr nargs save-nargs) @@ -3614,8 +3626,10 @@ ((arg :lisp) (lab :label)) - ((cr0 (:crf 0)) - (tag :u8))) - (clrlwi. tag arg (- arm::nbits-in-word arm::nlisptagbits)) - (bne cr0 lab)) + ()) + (tst arg (:$ arm::fixnummask)) + (bne lab)) + + + (define-arm-vinsn branch-unless-both-args-fixnums (() @@ -3625,8 +3639,9 @@ ((tag :u8))) (orr tag arg0 arg1) - (tst tag (:$ arm::tagmask)) + (tst tag (:$ arm::fixnummask)) (bne lab)) ;;; In case arm::*arm-opcodes* was changed since this file was compiled. +#+maybe-never (queue-fixup (fixup-vinsn-templates *arm-vinsn-templates* arm::*arm-opcode-numbers*)) Index: /branches/arm/compiler/ARM/arm2.lisp =================================================================== --- /branches/arm/compiler/ARM/arm2.lisp (revision 13740) +++ /branches/arm/compiler/ARM/arm2.lisp (revision 13741) @@ -503,22 +503,19 @@ (setf (uvref function (1+ 2)) (aref imms i))) (setf (uvref function (+ numimms 1)) bits) - (let* ((maxpc (arm-lap-encode-regsave-info (arm-lap-do-labels))) - (code-vector-size (+ traceback-size (ash maxpc -2) prefix-size))) - (let* ((code-vector (%alloc-misc code-vector-size + (let* ((code-vector-size (arm::arm-finalize code data)) + (code-vector (%alloc-misc code-vector-size (if cross-compiling target::subtag-xcode-vector target::subtag-code-vector))) - (j 0)) - (dotimes (i prefix-size) - (setf (uvref code-vector i) (pop prefix))) - (arm-lap-resolve-labels) - (do-dll-nodes (insn *lap-instructions*) - (arm-lap-generate-instruction code-vector i insn) - (incf i)) - (unless (eql 0 traceback-size) - (add-traceback-table code-vector i traceback-string)) - (setf (uvref function 0) code-vector) - (%make-code-executable code-vector) - function)))) + (j 0)) + (dotimes (i prefix-size) + (setf (uvref code-vector i) (pop prefix))) + (arm-lap-resolve-labels) + (do-dll-nodes (insn *lap-instructions*) + (arm-lap-generate-instruction code-vector i insn) + (incf i)) + (setf (uvref function 1) code-vector) + (%make-code-executable code-vector) + function))) @@ -816,14 +813,9 @@ (reg-vars ())) (declare (type (unsigned-byte 16) nargs)) - (! save-lr) (if (<= nargs $numarmargregs) ; caller didn't vpush anything - (if *arm2-open-code-inline* - (! save-lisp-context-vsp) - (! save-lisp-context-vsp-ool)) + (! save-lisp-context-vsp) (let* ((offset (* (the fixnum (- nargs $numarmargregs)) *arm2-target-node-size*))) (declare (fixnum offset)) - (if *arm2-open-code-inline* - (! save-lisp-context-offset offset) - (! save-lisp-context-offset-ool offset)))) + (! save-lisp-context-offset offset))) (destructuring-bind (&optional zvar yvar xvar &rest stack-args) revargs (let* ((nstackargs (length stack-args))) @@ -4777,10 +4769,10 @@ (or (eq cd $backend-return) (arm2-mvpass-p cd))) -(defun arm2-expand-note (note) +(defun arm2-expand-note (note header) (let* ((lab (vinsn-note-label note))) (case (vinsn-note-class note) ((:begin-variable-scope :end-variable-scope :source-location-begin :source-location-end) - (setf (vinsn-label-info lab) (emit-lap-label lab)))))) + (setf (vinsn-label-info lab) (arm::emit-lap-label header lab)))))) (defun arm2-expand-vinsns (header current sections) @@ -4791,5 +4783,5 @@ (when (or t (vinsn-label-refs v) (null id)) (setf (vinsn-label-info v) (arm::emit-lap-label current v))) - (arm2-expand-note id))) + (arm2-expand-note current id))) (setq current (arm2-expand-vinsn v current sections)))) ;;; This doesn't have too much to do with anything else that's @@ -5337,20 +5329,16 @@ (let* ((fixval (or fix1 fix2)) (unboxed-fixval (if fixval (ash fixval *arm2-target-fixnum-shift*))) - (high (if fixval (if (= unboxed-fixval (logand #xffff0000 unboxed-fixval)) (ash unboxed-fixval -16)))) - (low (if fixval (unless high (if (= unboxed-fixval (logand #x0000ffff unboxed-fixval)) unboxed-fixval)))) - (otherform (if (or high low) (if fix1 form2 form1)))) + (ok-imm (and unboxed-fixval + (arm::encode-arm-immediate unboxed-fixval))) + (otherform (if ok-imm (if fix1 form2 form1)))) (if otherform (let* ((other-reg (arm2-one-untargeted-reg-form seg otherform arm::arg_z))) (when vreg - (ensuring-node-target (target vreg) - (if high - (! logior-high target other-reg high) - (! logior-low target other-reg low))))) + (ensuring-node-target (target vreg) + (! logior-immediate target other-reg unboxed-fixval)))) (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg form1 arm::arg_y form2 arm::arg_z) (if vreg (ensuring-node-target (target vreg) (! %logior2 target r1 r2))))) (^)))) -;;; in a lot of (typical ?) cases, it might be possible to use a -;;; rotate-and-mask instead of andi./andis. (defarm2 arm2-%ilogand2 %ilogand2 (seg vreg xfer form1 form2) @@ -5360,29 +5348,18 @@ (arm2-use-operator (%nx1-operator fixnum) seg vreg xfer (logand fix1 fix2)) (let* ((fixval (or fix1 fix2)) - (fixlen (if fixval (integer-length fixval))) - (unboxed-fixval (if fixval (ash fixval *arm2-target-fixnum-shift*))) - (high (if fixval (if (= unboxed-fixval (logand #xffff0000 unboxed-fixval)) (ash unboxed-fixval -16)))) - (low (if fixval (unless high (if (= unboxed-fixval (logand #x0000ffff unboxed-fixval)) unboxed-fixval)))) - (otherform (if (or high low) (if fix1 form2 form1)))) + (unboxed-fixval (if fixval (ash fixval arm::fixnum-shift))) + (ok-imm (and unboxed-fixval + (or (arm::encode-arm-immediate unboxed-fixval) + (arm::encode-arm-immediate + (logand #xffffffff (lognot unboxed-fixval)))))) + + (otherform (if ok-imm (if fix1 form2 form1)))) (if otherform (let* ((other-reg (arm2-one-untargeted-reg-form seg otherform arm::arg_z))) (when vreg - (ensuring-node-target (target vreg) - (if high - (! logand-high target other-reg high) - (! logand-low target other-reg low))))) - (if (and fixval (= fixlen (logcount fixval))) - (let* ((nbits (- *arm2-target-bits-in-word* - (1+ (+ *arm2-target-fixnum-shift* fixlen)))) - (otherreg (arm2-one-untargeted-reg-form seg (if fix1 form2 form1) arm::arg_z))) - - (if vreg (ensuring-node-target (target vreg) - (if (> fixval 0) - (! clear-left target otherreg nbits) - (! clear-right target otherreg (+ fixlen - *arm2-target-fixnum-shift*)))))) - + (ensuring-node-target (target vreg) + (! logand-immediate target other-reg unboxed-fixval)))) (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg form1 arm::arg_y form2 arm::arg_z) - (if vreg (ensuring-node-target (target vreg) (! %logand2 target r1 r2)))))) + (if vreg (ensuring-node-target (target vreg) (! %logand2 target r1 r2))))) (^))))) @@ -7778,5 +7755,5 @@ (defarm2 arm2-%setf-double-float %setf-double-float (seg vref xfer fnode fval) (arm2-vpush-register seg (arm2-one-untargeted-reg-form seg fnode arm::arg_z)) - (let* ((target ($ arm::fp1 :class :fpr :mode :double-float)) + (let* ((target ($ arm::d0 :class :fpr :mode :double-float)) (node ($ arm::arg_z))) (arm2-one-targeted-reg-form seg fval target) @@ -7790,5 +7767,5 @@ (defarm2 arm2-%setf-short-float %setf-short-float (seg vreg xfer fnode fval) (arm2-vpush-register seg (arm2-one-untargeted-reg-form seg fnode arm::arg_z)) - (let* ((target ($ arm::fp1 :class :fpr :mode :single-float)) + (let* ((target ($ arm::s0 :class :fpr :mode :single-float)) (freg ($ arm::arg_z))) (arm2-one-targeted-reg-form seg fval target)