Index: /branches/arm/compiler/ARM/arm-arch.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-arch.lisp (revision 13706) +++ /branches/arm/compiler/ARM/arm-arch.lisp (revision 13707) @@ -26,5 +26,4 @@ -(defvar *standard-arm-register-names* ()) (defvar *arm-register-names* ()) @@ -56,7 +55,7 @@ "ARM register ~s currently has value ~d." name (cdr pair) value) - (setf (cdr pair) value))) - (push (cons string value) *arm-register-names*)) - value)))) + (setf (cdr pair) value)))) + (push (cons string value) *arm-register-names*)) + value))) (defmacro defarmgpr (name val) @@ -106,6 +105,10 @@ (defarmgpr fname temp1) - - +(defarmgpr nargs imm2) + + + + +(defparameter *standard-arm-register-names* *arm-register-names*) @@ -487,5 +490,7 @@ -(defconstant canonical-nil-value (+ #x100000000 fulltag-nil)) +(defconstant canonical-nil-value (+ #x10000000 fulltag-nil)) +(defconstant nil-value canonical-nil-value) + ;;; T is almost adjacent to NIL: since NIL is a misaligned CONS, it spans ;;; two doublewords. The arithmetic difference between T and NIL is @@ -1270,4 +1275,21 @@ (defconstant uuo-format-binary 15) ; 4 bits of code, r1, r0 +;;; xtypes: 8-bit integers used to report type errors for types that can't +;;; be represented via tags. + +(defconstant xtype-unsigned-byte-24 252) +(defconstant xtype-array2d 248) +(defconstant xtype-array3d 244) +(defconstant xtype-integer 4) +(defconstant xtype-s64 8) +(defconstant xtype-u64 12) +(defconstant xtype-s32 16) +(defconstant xtype-u32 20) +(defconstant xtype-s16 24) +(defconstant xtype-u16 28) +(defconstant xtype-s8 32) +(defconstant xtype-u8 36) +(defconstant xtype-bit 40) + (provide "ARM-ARCH") Index: /branches/arm/compiler/ARM/arm-asm.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-asm.lisp (revision 13706) +++ /branches/arm/compiler/ARM/arm-asm.lisp (revision 13707) @@ -21,18 +21,20 @@ (in-package "ARM") -(defvar *arm-condition-names* (make-hash-table :test #'equalp)) - -(dolist (pair '((eq . 0) (ne . 1) - (cc . 2) (hs . 2) (cs . 3) (lo .3) - (mi . 4) (pl . 5) - (vs . 6) (vc . 7) - (hi . 8) (ls . 9) - (ge . 10) (lt . 11) - (gt . 12) (le . 13) - (al . 14))) ; never say nv - (setf (gethash (string (car pair)) *arm-condition-names*) (cdr pair))) +(defparameter *arm-condition-names* '(("eq" . 0) ("ne" . 1) + ("cc" . 2) ("hs" . 2) ("cs" . 3) ("lo" . 3) + ("mi" . 4) ("pl" . 5) + ("vs" . 6) ("vc" . 7) + ("hi" . 8) ("ls" . 9) + ("ge" . 10) ("lt" . 11) + ("gt" . 12) ("le" . 13) + ("al" . 14))) + + (defun lookup-arm-condition-name (name) - (values (gethash (string name) *arm-condition-names*))) + (cdr (assoc name *arm-condition-names* :test #'string-equal))) + +(defun lookup-arm-condition-value (val) + (car (rassoc val *arm-condition-names* :test #'eq))) (defun need-arm-condition-name (name) @@ -42,4 +44,17 @@ (defvar *arm-constants* ()) (defvar *lap-labels* ()) +(defvar *called-subprim-jmp-labels* ()) + + +(defun arm-subprimitive-address (x) + (if (and x (or (symbolp x) (stringp x))) + (let* ((info (find x arm::*arm-subprims* :test #'string-equal :key #'ccl::subprimitive-info-name))) + (when info + (ccl::subprimitive-info-offset info))))) + +(defun arm-subprimitive-name (addr) + (let* ((info (find addr arm::*arm-subprims* :key #'ccl::subprimitive-info-offset))) + (when info + (string (ccl::subprimitive-info-name info))))) @@ -73,7 +88,7 @@ ordinal ;if we need this val - mask ;for disassembler (flags 0) - operand-types) + operand-types + mask-list) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -91,4 +106,6 @@ rm b + subprim + mem8 ) @@ -105,4 +122,6 @@ (:rm . ,arm-operand-type-rm) (:b . ,arm-operand-type-b) + (:subprim . ,arm-operand-type-subprim) + (:mem8 . ,arm-operand-type-mem8) )) @@ -116,8 +135,10 @@ (ccl::defenum (:prefix "ARM-INSTRUCTION-FLAG-") non-conditional ;doesn't use standard condition field + prefer-separate-cond ) (defparameter *arm-instruction-flag-names* `((:non-conditional . ,arm-instruction-flag-non-conditional) + (:prefer-separate-cond . ,arm-instruction-flag-prefer-separate-cond) )) @@ -140,99 +161,401 @@ (defvar *arm-instruction-ordinals* (make-hash-table :test #'equalp)) -(defparameter *arm-instruction-stack* (make-array 100 :fill-pointer 0)) - - -(defun %define-arm-instruction (name value flags operand-types) - (let* ((ordinal (length *arm-instruction-stack*))) - (setf (gethash (string name) *arm-instruction-ordinals*) - ordinal) - (vector-push-extend - (make-arm-instruction-template :name name + + +(defun %define-arm-instruction (name value mask-list flags operand-types) + (make-arm-instruction-template :name name :val value - :ordinal ordinal + :ordinal nil + :mask-list mask-list :flags (or flags 0) - :operand-types operand-types) - *arm-instruction-stack*) - name)) - -(defmacro define-arm-instruction (name value flag-names &rest operand-type-names) - `(%define-arm-instruction ,(string-downcase name) ,value ,(%encode-arm-instruction-flag flag-names) ',(mapcar #'encode-arm-operand-type operand-type-names))) - - -(define-arm-instruction and #x0000000 () :rd :rn :shifter) -(define-arm-instruction ands #x0100000 () :rd :rn :shifter) -(define-arm-instruction eor #x0200000 () :rd :rn :shifter) -(define-arm-instruction eors #x0300000 () :rd :rn :shifter) -(define-arm-instruction sub #x0400000 () :rd :rn :shifter) -(define-arm-instruction subs #x0500000 () :rd :rn :shifter) -(define-arm-instruction add #x0800000 () :rd :rn :shifter) -(define-arm-instruction adds #x0900000 () :rd :rn :shifter) -(define-arm-instruction adc #x0a00000 () :rd :rn :shifter) -(define-arm-instruction adcs #x0b00000 () :rd :rn :shifter) -(define-arm-instruction sbc #x0c00000 () :rd :rn :shifter) -(define-arm-instruction sbcs #x0d00000 () :rd :rn :shifter) -(define-arm-instruction orr #x1800000 () :rd :rn :shifter) -(define-arm-instruction orrs #x1900000 () :rd :rn :shifter) -(define-arm-instruction bic #x1c00000 () :rd :rn :shifter) -(define-arm-instruction bics #x1d00000 () :rd :rn :shifter) -(define-arm-instruction tst #x1100000 () :rd :shifter) -(define-arm-instruction tsts #x1100000 () :rd :shifter) -(define-arm-instruction cmp #x1500000 () :rd :shifter) -(define-arm-instruction cmps #x1500000 () :rd :shifter) -(define-arm-instruction cmn #x1700000 () :rd :shifter) -(define-arm-instruction cmns #x1700000 () :rd :shifter) - -(define-arm-instruction mov #x1a00000 () :rd :shifter) -(define-arm-instruction movs #x1b00000 () :rd :shifter) -(define-arm-instruction mvn #x1e00000 () :rd :shifter) -(define-arm-instruction mvns #x1f00000 () :rd :shifter) - -(define-arm-instruction ldr #x4100000 () :rd :mem12) -(define-arm-instruction ldrb #x4500000 () :rd :mem12) -(define-arm-instruction str #x4000000 () :rd :mem12) -(define-arm-instruction strb #x4400000 () :rd :mem12) - -(define-arm-instruction stm #x8800000 () :rnw :reglist) -(define-arm-instruction stmia #x8800000 () :rnw :reglist) -(define-arm-instruction stmea #x8800000 () :rnw :reglist) -(define-arm-instruction ldm #x8900000 () :rnw :reglist) -(define-arm-instruction ldmia #x8900000 () :rnw :reglist) -(define-arm-instruction ldmfd #x8900000 () :rnw :reglist) - -(define-arm-instruction b #xa000000 () :b) -(define-arm-instruction bl #xb000000 () :b) -(define-arm-instruction bx #x12fff10 () :rm) -(define-arm-instruction blx #x12fff30 () :rm) - -;;; UUOs + :operand-types operand-types)) + +(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) )) + +(defparameter *arm-instruction-table* + (vector + +;;; UUOs. + ;;; Nullary UUOs -(define-arm-instruction uuo-alloc-trap #x07f000f0 ()) -(define-arm-instruction uuo-error-wrong-nargs #x07f001f0 ()) -(define-arm-instruction uuo-gc-trap #x07f002f0 ()) -(define-arm-instruction uuo-debug-trap #x07f003f0 ()) -(define-arm-instruction uuo-interrupt-now #x07f004f0 ()) -(define-arm-instruction uuo-suspend-now #x07f005f0 ()) + (define-arm-instruction uuo-alloc-trap () + #x07f000f0 + #x0fffffff + (:prefer-separate-cond)) + (define-arm-instruction uuo-error-wrong-nargs () + #x07f001f0 + #x0fffffff + (:prefer-separate-cond)) + (define-arm-instruction uuo-gc-trap () + #x07f002f0 + #x0fffffff + (:prefer-separate-cond)) + (define-arm-instruction uuo-debug-trap () + #x07f003f0 + #x0fffffff + (:prefer-separate-cond)) + (define-arm-instruction uuo-interrupt-now () + #x07f004f0 + #x0fffffff + (:prefer-separate-cond)) + (define-arm-instruction uuo-suspend-now () + #x07f005f0 + #x0fffffff + (:prefer-separate-cond)) ;;; Misc format -(define-arm-instruction uuo-error-reg-not-lisptag #x07f000f2 () :uuoA :uuo-unary) -(define-arm-instruction uuo-error-reg-not-fulltag #x07f000f3 () :uuoA :uuo-unary) -(define-arm-instruction uuo-error-reg-not-xtype #x07f000f4 () :uuoA :uuo-unary) -(define-arm-instruction uuo-cerror-reg-not-lisptag #x07f000fa () :uuoA :uuo-unary) -(define-arm-instruction uuo-cerror-reg-not-fulltag #x07f000fb () :uuoA :uuo-unary) -(define-arm-instruction uuo-cerror-reg-not-xtype #x07f000fc () :uuoA :uuo-unary) + (define-arm-instruction uuo-error-reg-not-lisptag (:uuoA :uuo-unary) + #x07f000f2 + #x0ff000ff + (:prefer-separate-cond)) + (define-arm-instruction uuo-error-reg-not-fulltag (:uuoA :uuo-unary) + #x07f000f3 + #x0ff000ff + (:prefer-separate-cond)) + (define-arm-instruction uuo-error-reg-not-xtype (:uuoA :uuo-unary) + #x07f000f4 + #x0ff000ff + (:prefer-separate-cond)) + (define-arm-instruction uuo-cerror-reg-not-lisptag (:uuoA :uuo-unary) + #x07f000fa + #x0ff000ff + (:prefer-separate-cond)) + (define-arm-instruction uuo-cerror-reg-not-fulltag (:uuoA :uuo-unary) + #x07f000fb + #x0ff000ff + (:prefer-separate-cond)) + (define-arm-instruction uuo-cerror-reg-not-xtype (:uuoA :uuo-unary) + #x07f000fc + #x0ff000ff + (:prefer-separate-cond)) ;;; Unary UUOs -(define-arm-instruction uuo-error-unbound #x07f000f1 () :uuoA) -(define-arm-instruction uuo-cerror-unbound #x07f010f1 () :uuoA) -(define-arm-instruction uuo-error-not-callable #x07f020f1 () :uuoA) -(define-arm-instruction uuo-tlb-too-small #x07f030f1 () :uuoA) -(define-arm-instruction uuo-error-no-throw-tag #x07f040f1 () :uuoA) + (define-arm-instruction uuo-error-unbound (:uuoA) + #x07f000f1 + #x0ffff0ff + (:prefer-separate-cond)) + (define-arm-instruction uuo-cerror-unbound (:uuoA) + #x07f010f1 + #x0ffff0ff + (:prefer-separate-cond)) + (define-arm-instruction uuo-error-not-callable (:uuoA) + #x07f020f1 + #x0ffff0ff + (:prefer-separate-cond)) + (define-arm-instruction uuo-tlb-too-small (:uuoA) + #x07f030f1 + #x0ffff0ff + (:prefer-separate-cond)) + (define-arm-instruction uuo-error-no-throw-tag (:uuoA) + #x07f040f1 + #x0ffff0ff + (:prefer-separate-cond)) ;;; Binary UUOs -(define-arm-instruction uuo-error-vector-bounds #x07f000ff () :uuoA :uuoB) -(define-arm-instruction uuo-error-array-bounds #x07f100ff () :uuoA :uuoB) - - -(defparameter *arm-instruction-table* (copy-seq *arm-instruction-stack*)) + (define-arm-instruction uuo-error-vector-bounds (:uuoA :uuoB) + #x07f000ff + #x0fff00ff + (:prefer-separate-cond)) + (define-arm-instruction uuo-error-array-bounds (:uuoA :uuoB) + #x07f100ff + #x0fff00ff + (:prefer-separate-cond)) + + + (define-arm-instruction and (:rd :rn :shifter) + #x00000000 + ((#x02000000 . #x0ff00000) + (#x00000000 . #x0ff00010) + (#x00000010 . #x0ff00090)) + ()) + (define-arm-instruction ands (:rd :rn :shifter) + #x00100000 + ((#x03000000 . #x0ff00000) + (#x01000000 . #x0ff00010) + (#x01000010 . #x0ff00090)) + ()) + (define-arm-instruction eor (:rd :rn :shifter) + #x00200000 + ((#x02200000 . #x0ff00000) + (#x00200000 . #x0ff00010) + (#x00200010 . #x0ff00090)) + ()) + (define-arm-instruction eors (:rd :rn :shifter) + #x00300000 + ((#x02300000 . #x0ff00000) + (#x00300000 . #x0ff00010) + (#x00300010 . #x0ff00090)) + ()) + (define-arm-instruction sub (:rd :rn :shifter) + #x00400000 + ((#x02400000 . #x0ff00000) + (#x00400000 . #x0ff00010) + (#x00400010 . #x0ff00090)) + ()) + (define-arm-instruction subs (:rd :rn :shifter) + #x00500000 + ((#x02500000 . #x0ff00000) + (#x00500000 . #x0ff00010) + (#x00500010 . #x0ff00090)) + ()) + (define-arm-instruction rsb (:rd :rn :shifter) + #x00600000 + ((#x02600000 . #x0ff00000) + (#x00600000 . #x0ff00010) + (#x00600010 . #x0ff00090)) + ()) + (define-arm-instruction rsbs (:rd :rn :shifter) + #x00700000 + ((#x02700000 . #x0ff00000) + (#x00700000 . #x0ff00010) + (#x00700010 . #x0ff00090)) + ()) + (define-arm-instruction add (:rd :rn :shifter) + #x00800000 + ((#x02800000 . #x0ff00000) + (#x00800000 . #x0ff00010) + (#x00800010 . #x0ff00090)) + ()) + (define-arm-instruction adds (:rd :rn :shifter) + #x00900000 + ((#x02900000 . #x0ff00000) + (#x00900000 . #x0ff00010) + (#x00900010 . #x0ff00090)) + ()) + + (define-arm-instruction adc (:rd :rn :shifter) + #x00a00000 + ((#x02a00000 . #x0ff00000) + (#x00a00000 . #x0ff00010) + (#x00a00010 . #x0ff00090)) + ()) + (define-arm-instruction adcs (:rd :rn :shifter) + #x00b00000 + ((#x02b00000 . #x0ff00000) + (#x00b00000 . #x0ff00010) + (#x00b00010 . #x0ff00090)) + ()) + (define-arm-instruction sbc (:rd :rn :shifter) + #x00c00000 + ((#x02c00000 . #x0ff00000) + (#x00c00000 . #x0ff00010) + (#x00c00010 . #x0ff00090)) + ()) + (define-arm-instruction sbcs (:rd :rn :shifter) + #x00d00000 + ((#x02d00000 . #x0ff00000) + (#x00d00000 . #x0ff00010) + (#x00d00010 . #x0ff00090)) + ()) + (define-arm-instruction rsc (:rd :rn :shifter) + #x00e00000 + ((#x02e00000 . #x0ff00000) + (#x00e00000 . #x0ff00010) + (#x00e00010 . #x0ff00090)) + ()) + (define-arm-instruction rscs (:rd :rn :shifter) + #x00e00000 + ((#x02e00000 . #x0ff00000) + (#x00e00000 . #x0ff00010) + (#x00e00010 . #x0ff00090)) + ()) + (define-arm-instruction tst (:rd :shifter) + #x01100000 + ((#x03100000 . #x0ff00000) + (#x01100000 . #x0ff00010) + (#x01100010 . #x0ff00090)) + ()) + (define-arm-instruction tsts (:rd :shifter) + #x01100000 + ((#x03100000 . #x0ff00000) + (#x01100000 . #x0ff00010) + (#x01100010 . #x0ff00090)) + ()) + (define-arm-instruction orr (:rd :rn :shifter) + #x01800000 + ((#x03800000 . #x0ff00000) + (#x01800000 . #x0ff00010) + (#x01800010 . #x0ff00090)) + ()) + (define-arm-instruction orrs (:rd :rn :shifter) + #x01900000 + ((#x03900000 . #x0ff00000) + (#x01900000 . #x0ff00010) + (#x01900010 . #x0ff00090)) + ()) + (define-arm-instruction bic (:rd :rn :shifter) + #x01c00000 + ((#x03c00000 . #x0ff00000) + (#x01c00000 . #x0ff00010) + (#x01c00010 . #x0ff00090)) + ()) + (define-arm-instruction bics (:rd :rn :shifter) + #x01d00000 + ((#x03d00000 . #x0ff00000) + (#x01d00000 . #x0ff00010) + (#x01d00010 . #x0ff00090)) + ()) + (define-arm-instruction cmp (:rd :shifter) + #x01500000 + ((#x03500000 . #x0ff00000) + (#x01500000 . #x0ff00010) + (#x01500010 . #x0ff00090)) + ()) + (define-arm-instruction cmps (:rd :shifter) + #x01500000 + ((#x03500000 . #x0ff00000) + (#x01500000 . #x0ff00010) + (#x01500010 . #x0ff00090)) + ()) + (define-arm-instruction cmn (:rd :shifter) + #x01700000 + ((#x03700000 . #x0ff00000) + (#x01700000 . #x0ff00010) + (#x01700010 . #x0ff00090)) + ()) + (define-arm-instruction cmns (:rd :shifter) + #x01700000 + ((#x03700000 . #x0ff00000) + (#x01700000 . #x0ff00010) + (#x01700010 . #x0ff00090)) + ()) + + ;; (ba subprim-name) -> (mov pc ($ subprim-address)) + (define-arm-instruction ba (:subprim) + #x03a0f000 + #x0ffff000 + ()) + + (define-arm-instruction mov (:rd :shifter) + #x01a00000 + ((#x03a00000 . #x0ff00000) + (#x01a00000 . #x0ff00010) + (#x01a00010 . #x0ff00090)) + ()) + (define-arm-instruction movs (:rd :shifter) + #x01b00000 + ((#x03b00000 . #x0ff00000) + (#x01b00000 . #x0ff00010) + (#x01b00010 . #x0ff00090)) + ()) + (define-arm-instruction mvn (:rd :shifter) + #x01e00000 + ((#x03e00000 . #x0ff00000) + (#x01e00000 . #x0ff00010) + (#x01e00010 . #x0ff00090)) + ()) + (define-arm-instruction mvns (:rd :shifter) + #x01f00000 + ((#x03f00000 . #x0ff00000) + (#x01f00000 . #x0ff00010) + (#x01f00010 . #x0ff00090)) + ()) + + (define-arm-instruction ldr (:rd :mem12) + #x04100000 + #x0c500000 + ()) + (define-arm-instruction ldrb (:rd :mem12) + #x04500000 + #x0c500000 + ()) + (define-arm-instruction str (:rd :mem12) + #x04000000 + #x0c500000 + ()) + (define-arm-instruction strb (:rd :mem12) + #x04400000 + #x0c500000 + ()) + (define-arm-instruction ldrh (:rd :mem8) + #x001000b0 + #x0e3000f0 + ()) + (define-arm-instruction strh (:rd :mem8) + #x000000b0 + #x0e3000f0 + ()) + (define-arm-instruction ldrsh (:rd :mem8) + #x001000f0 + #x0e3000f0 + ()) + (define-arm-instruction ldrsb (:rd :mem8) + #x001000d0 + #x0e3000f0 + ()) + + (define-arm-instruction stm (:rnw :reglist) + #x08800000 + #x0ff00000 + ()) + (define-arm-instruction stmia (:rnw :reglist) + #x08800000 + #x0ff00000 + ()) + (define-arm-instruction stmea (:rnw :reglist) + #x08800000 + #x0ff00000 + ()) + (define-arm-instruction ldmia (:rnw :reglist) + #x08900000 + #x0ff00000 + ()) + (define-arm-instruction ldm (:rnw :reglist) + #x08900000 + #x0ff00000 + ()) + (define-arm-instruction ldmfd (:rnw :reglist) + #x08900000 + #x0ff00000 + ()) + (define-arm-instruction stmdb (:rnw :reglist) + #x09000000 + #x0ff00000 + ()) + (define-arm-instruction stmfb (:rnw :reglist) + #x09000000 + #x0ff00000 + ()) + (define-arm-instruction stmfd (:rnw :reglist) + #x09000000 + #x0ff00000 + ()) + (define-arm-instruction ldmdb (:rnw :reglist) + #x09100000 + #x0ff00000 + ()) + (define-arm-instruction ldmea (:rnw :reglist) + #x09100000 + #x0ff00000 + ()) + + (define-arm-instruction b (:b) + #x0a000000 + #x0e000000 + ()) + (define-arm-instruction bl (:b) + #x0b000000 + #x0e000000 + ()) + (define-arm-instruction bx (:rm) + #x012fff10 + #x0ffffff0 + ()) + (define-arm-instruction blx (:rm) + #x012fff30 + #x0ffffff0 + ()) + )) + +(dotimes (i (length *arm-instruction-table*)) + (let* ((template (svref *arm-instruction-table* i)) + (name (arm-instruction-template-name template))) + (setf (arm-instruction-template-ordinal template) i + (gethash name *arm-instruction-ordinals*) i))) + + + + (defun lookup-arm-instruction (name) @@ -287,5 +610,5 @@ (ash u32 (- r))))))) -;;; Return a 12-bit value encodeing u32 as an 8-bit constant rotated +;;; Return a 12-bit value encoding u32 as an 8-bit constant rotated ;;; by an even number of bits if u32 can be encoded that way, nil ;;; otherwise. @@ -295,5 +618,5 @@ ((= rot 32) (values nil nil)) (let* ((a (arm-rotate-left u32 rot))) - (if (<= a #xff) + (when (<= a #xff) (return (logior (ash rot 7) a)))))) @@ -301,5 +624,6 @@ (eval-when (:execute :load-toplevel) (defstruct (instruction-element (:include ccl::dll-node)) - address) + address + (size 0)) ;;; A LAP-INSTRUCTION's field-values list contains (byte-spec . value) @@ -316,17 +640,11 @@ ;;; be applied at vinsn-definition time. - (defstruct (lap-instruction (:include instruction-element) - (:constructor %make-lap-instruction (source))) + (defstruct (lap-instruction (:include instruction-element (size 4)) + (:constructor %make-lap-instruction (source))) source ; for LAP, maybe vinsn-template (opcode 0) - field-values + vinsn-info ;tbd ) - (defstruct (lap-note (:include instruction-element)) - peer - id) - - (defstruct (lap-note-begin (:include lap-note))) - (defstruct (lap-note-end (:include lap-note))) (defstruct (lap-label (:include instruction-element) @@ -339,14 +657,10 @@ -(defun make-field-value (size position value) - (cons (byte size position) value)) - -(defun add-field-value (instruction size position value) - (push (make-field-value size position value) - (lap-instruction-field-values instruction))) - -(defun set-field-value (instruction size position value) +(eval-when (:compile-toplevel :execute) + (declaim (inline set-field-value))) + +(defun set-field-value (instruction bytespec value) (setf (lap-instruction-opcode instruction) - (dpb value (byte size position) (lap-instruction-opcode instruction)))) + (dpb value bytespec (lap-instruction-opcode instruction)))) @@ -416,27 +730,24 @@ )) -(defconstant arm-pseudofield-shifter-constant 0) (defun parse-rd-operand (form instruction) - (set-field-value instruction 4 12 (need-arm-gpr form))) + (set-field-value instruction (byte 4 12) (need-arm-gpr form))) (defun parse-rn-operand (form instruction) - (set-field-value instruction 4 16 (need-arm-gpr form))) + (set-field-value instruction (byte 4 16) (need-arm-gpr form))) (defun parse-shifter-operand (form instruction) (if (atom form) ;; rm is shorthand for (:lsl rm (:$ 0)); the :lsl is encoded as 0. - (set-field-value instruction 12 0 (need-arm-gpr form)) + (set-field-value instruction (byte 12 0) (need-arm-gpr form)) (if (ccl::quoted-form-p form) - (add-field-value instruction 0 arm-pseudofield-shifter-constant - (need-constant form)) + (insert-shifter-constant (need-constant form) instruction) (let* ((op (keywordize (car form)))) (ecase op (:$ (destructuring-bind (value) (cdr form) - (add-field-value instruction 0 arm-pseudofield-shifter-constant - (eval value)))) + (insert-shifter-constant (eval value) instruction))) (:rrx (destructuring-bind (reg) (cdr form) - (set-field-value instruction 12 0 + (set-field-value instruction (byte 12 0) (logior (need-arm-gpr reg) (ash (encode-arm-shift-type :ror) 5))))) @@ -444,5 +755,5 @@ (destructuring-bind (reg count) (cdr form) (if (atom count) - (set-field-value instruction 12 0 + (set-field-value instruction (byte 12 0) (logior (need-arm-gpr reg) (ash 1 4) @@ -451,96 +762,109 @@ (ecase (keywordize (car count)) (:$ (destructuring-bind (countval) (cdr count) - (set-field-value instruction 12 0 + (set-field-value instruction (byte 12 0) (logior (need-arm-gpr reg) (ash (encode-arm-shift-type op) 5) - (ash (logand 31 (eval countval)) 8)))))))))))))) + (ash (logand 31 (eval countval)) 7)))))))))))))) -(defun insert-shifter-constant (value opcode) - (let* ((constant (encode-arm-immediate value))) - (if constant - (logior constant (logior (ash 1 25) opcode)) - ;; If value couldn't be encoded but its complement can be - ;; and there's an instruction that can operate on complemented - ;; values, change the instruction and encode the complemented - ;; value. If that doesn't work, try negating the value and - ;; seeing if there's an equivalent instruction that could use - ;; that. If none of this works, complain that the value can't - ;; be encoded. - (let* ((op (ldb (byte 4 21) opcode)) - (newop nil)) - (if (or (and (setq constant (encode-arm-immediate (lognot value))) - (setq newop (svref op *equivalent-complemented-opcodes*))) - (and (setq constant (encode-arm-immediate (- value))) - (setq newop (svref op *equivalent-negated-opcodes*)))) - (logior constant - (logior (ash 1 25) (dpb newop (byte 4 21) opcode))) - (error "Can't encode ARM constant ~s." value)))))) +(defun insert-shifter-constant (value instruction) + (let* ((opcode (lap-instruction-opcode instruction)) + (constant (encode-arm-immediate value))) + (setf (lap-instruction-opcode instruction) + (if constant + (logior constant (logior (ash 1 25) opcode)) + ;; If value couldn't be encoded but its complement can be + ;; and there's an instruction that can operate on complemented + ;; values, change the instruction and encode the complemented + ;; value. If that doesn't work, try negating the value and + ;; seeing if there's an equivalent instruction that could use + ;; that. If none of this works, complain that the value can't + ;; be encoded. + (let* ((op (ldb (byte 4 21) opcode)) + (newop nil)) + (if (or (and (setq constant (encode-arm-immediate (lognot value))) + (setq newop (svref *equivalent-complemented-opcodes* op))) + (and (setq constant (encode-arm-immediate (- value))) + (setq newop (svref *equivalent-negated-opcodes* op)))) + (logior constant + (logior (ash 1 25) (dpb newop (byte 4 21) opcode))) + (error "Can't encode ARM constant ~s." value))))))) + +(defun set-addressing-mode (instruction mode constant-index) + ;; Look at mode and set P/W/U bits. If CONSTANT-INDEX is + ;; true, the U bit depends on the sign of the constant. + (ecase mode + ((:@ :+@ :+@! :@!) + ;; Preindexed, no writeback unless :+@! , add register operands. + (unless constant-index + (set-field-value instruction (byte 1 23) 1)) + (when (eq mode :+@!) + (set-field-value instruction (byte 1 21) 1)) + (set-field-value instruction (byte 1 24) 1)) + ((:-@ :-@!) + ;; Preindexed. Leave the U bit clear, maybe set W if writeback. + (when (eq mode :-@!) + (set-field-value instruction (byte 1 21) 1)) + (set-field-value instruction (byte 1 24) 1)) + ((:@+ :@-) + ;; Postindex; writeback is implicit (and setting P and W would + ;; change the instruction.) + (unless (or (eq mode :@-) constant-index) + (set-field-value instruction (byte 1 23) 1))))) ;;; "general" address operand, as used in LDR/LDRB/STR/STRB -(defun parse-memory-operand (form instruction) +(defun parse-m12-operand (form instruction) (if (atom form) (error "Invalid memory operand ~s" form) (let* ((mode (keywordize (car form)))) - (destructuring-bind (rn &optional (index '(:$ 0) index-p)) (cdr form) - (unless (or index-p (eq mode :@)) - (error "missing index in memory operand ~s." form)) - (set-field-value instruction 4 16 (need-arm-gpr rn)) - (let* ((quoted (ccl::quoted-form-p form)) - (index-op (if quoted :quote (and (consp index) (keywordize (car index))))) - (constant-index (or quoted (eq index-op :$)))) - (cond (constant-index - (destructuring-bind (val) (cdr index) - (let* ((constval (if quoted - (need-constant index) - (eval val)))) - (if (< constval 0) - (setq constval (- constval)) - ;; das u bit - (set-field-value instruction 1 23 1)) - (unless (typep constval '(unsigned-byte 12)) - (warn "constant offset too large : ~s" constval)) - (set-field-value instruction 12 0 constval)))) - (t - (set-field-value instruction 1 25 1) - (if (atom index) - (set-field-value instruction 12 0 (need-arm-gpr index)) - ;; Shifts here are always by a constant (not another reg) - (if (eq index-op :rrx) - (destructuring-bind (rm) (cdr index) - (set-field-value instruction 12 0 - (logior (need-arm-gpr rm) - (ash (encode-arm-shift-type :ror) 5)))) + (if (eq mode :=) + (destructuring-bind (label) (cdr form) + (when (arm::arm-subprimitive-address label) + (error "Invalid label in ~s." form)) + (set-field-value instruction (byte 4 16) arm::pc) + (set-field-value instruction (byte 1 24) 1) ;P bit + ;; Insert function will have to set U bit appropriately. + (lap-note-label-reference label instruction :mem12)) + (destructuring-bind (rn &optional (index '(:$ 0) index-p)) (cdr form) + (unless (or index-p (eq mode :@)) + (error "missing index in memory operand ~s." form)) + (set-field-value instruction (byte 4 16) (need-arm-gpr rn)) + (let* ((quoted (ccl::quoted-form-p index)) + (index-op (if quoted :quote (and (consp index) (keywordize (car index))))) + (constant-index (or quoted (eq index-op :$)))) + (cond (constant-index + (destructuring-bind (val) (cdr index) + (let* ((constval (if quoted + (need-constant index) + (eval val)))) + (if (< constval 0) + (setq constval (- constval)) + ;; das u bit + (set-field-value instruction (byte 1 23) 1)) + (unless (typep constval '(unsigned-byte 12)) + (warn "constant offset too large : ~s" constval)) + (set-field-value instruction (byte 12 0) constval)))) + (t + (set-field-value instruction (byte 1 25) 1) + (if (atom index) + (set-field-value instruction (byte 12 0) (need-arm-gpr index)) + ;; Shifts here are always by a constant (not another reg) + (if (eq index-op :rrx) + (destructuring-bind (rm) (cdr index) + (set-field-value instruction (byte 12 0) + (logior (need-arm-gpr rm) + (ash (encode-arm-shift-type :ror) 5)))) - (destructuring-bind (rm shift-expr) (cdr index) - (unless (and (consp shift-expr) - (eq (keywordize (car shift-expr)) :$)) - (error "Shift count must be immediate : ~s" shift-expr)) - (destructuring-bind (count-expr) (cdr shift-expr) - (set-field-value instruction 12 0 - (logior (need-arm-gpr rm) - (ash (encode-arm-shift-type - index-op) 5) - (ash (logand 31 (eval count-expr)) - 7))))))))) - ;; Now, look at mode and set P/W/U bits. If CONSTANT-INDEX is - ;; true, the U bit depends on the sign of the constant. - (ecase mode - ((:@ :+@ :+@!) - ;; Preindexed, no writeback unless :+@! , add register operands. - (unless constant-index - (set-field-value instruction 1 23 1)) - (when (eq mode :+@!) - (set-field-value instruction 1 21 1)) - (set-field-value instruction 1 24 1)) - ((:-@ :-@!) - ;; Preindexed. Leave the U bit clear, maybe set W if writeback. - (when (eq mode :-@!) - (set-field-value instruction 1 21 1)) - (set-field-value instruction 1 24 1)) - ((:@+ :@-) - ;; Postindex; writeback is implicit (and setting P and W would - ;; change the instruction.) - (unless (or (eq mode :@-) constant-index) - (set-field-value instruction 1 23 1))))))))) + (destructuring-bind (rm shift-expr) (cdr index) + (unless (and (consp shift-expr) + (eq (keywordize (car shift-expr)) :$)) + (error "Shift count must be immediate : ~s" shift-expr)) + (destructuring-bind (count-expr) (cdr shift-expr) + (set-field-value instruction (byte 12 0) + (logior (need-arm-gpr rm) + (ash (encode-arm-shift-type + index-op) 5) + (ash (logand 31 (eval count-expr)) + 7))))))))) + (set-addressing-mode instruction mode constant-index))))))) (defun parse-reglist-operand (form instruction) @@ -553,33 +877,66 @@ (if (zerop mask) (error "Empty register list ~s." form) - (set-field-value instruction 16 0 mask)))) + (set-field-value instruction (byte 16 0) mask)))) (defun parse-rnw-operand (form instruction) (if (atom form) - (set-field-value instruction 4 16 (need-arm-gpr form)) + (set-field-value instruction (byte 4 16) (need-arm-gpr form)) (if (eq (keywordize (car form)) :!) (destructuring-bind (rn) (cdr form) - (set-field-value instruction 1 21 1) - (set-field-value instruction 4 16 (need-arm-gpr rn))) + (set-field-value instruction (byte 1 21) 1) + (set-field-value instruction (byte 4 16) (need-arm-gpr rn))) (error "Unrecognize writeback indicator in ~s." form)))) (defun parse-uuoA-operand (form instruction) - (set-field-value instruction 4 8 (need-arm-gpr form))) + (set-field-value instruction (byte 4 8) (need-arm-gpr form))) (defun parse-uuo-unary-operand (form instruction) - (set-field-value instruction 4 12 (need-constant form))) + (set-field-value instruction (byte 8 12) (need-constant form))) (defun parse-uuoB-operand (form instruction) - (set-field-value instruction 4 12 (need-arm-gpr form))) + (set-field-value instruction (byte 4 12) (need-arm-gpr form))) (defun parse-rm-operand (form instruction) - (set-field-value instruction 4 0 (need-arm-gpr form))) + (set-field-value instruction (byte 4 0) (need-arm-gpr form))) (defun parse-b-operand (form instruction) - (lap-note-label-reference form instruction :b)) - - - - + (let* ((address (arm-subprimitive-address form))) + (if address + (let* ((lab (or (find-lap-label form) + (make-lap-label form)))) + (pushnew lab *called-subprim-jmp-labels*) + (push (cons instruction :b) (lap-label-refs lab))) + (lap-note-label-reference form instruction :b)))) + +(defun parse-subprim-operand (form instruction) + (let* ((address (arm-subprimitive-address form))) + (unless address + (error "Unknown ARM subprimitive : ~s" form)) + (set-field-value instruction (byte 12 0) (encode-arm-immediate address)))) + +(defun parse-m8-operand (form instruction) + (if (atom form) + (error "Invalid memory operand ~s." form) + (let* ((mode (keywordize (car form))) + (constant-index nil)) + (destructuring-bind (rn index) (cdr form) + (set-field-value instruction (byte 4 16) (need-arm-gpr rn)) + (cond ((atom index) + (set-field-value instruction (byte 4 0) (need-arm-gpr index)) + (set-field-value instruction (byte 25 1) 1)) + (t (unless (eq (keywordize (car index)) :$) + (error "Invalid index: ~s." index)) + (destructuring-bind (val) (cdr index) + (let* ((value (eval val))) + (setq constant-index t) + (if (< value 0) + (setq value (- value)) + (set-field-value instruction (byte 23 1) 1)) + (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value)) + (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value))))))) + (set-addressing-mode instruction mode constant-index)))) + + + (defparameter *arm-operand-parsers* @@ -587,5 +944,5 @@ parse-rn-operand parse-shifter-operand - parse-memory-operand + parse-m12-operand parse-reglist-operand parse-rnw-operand @@ -595,10 +952,25 @@ parse-rm-operand parse-b-operand + parse-subprim-operand + parse-m8-operand )) -;;; FORM is a list; its car isn't a pseudo-op or lapmacro; try to generate -;;; an instruction. -(defun assemble-instruction (form) - (let* ((insn (%make-lap-instruction form))) + + +(defun make-lap-instruction (form) + (let* ((insn (ccl::alloc-dll-node *lap-instruction-freelist*))) + (if (typep insn 'lap-instruction) + (progn + (setf (lap-instruction-source insn) form + (lap-instruction-address insn) nil + (lap-instruction-vinsn-info insn) nil + (lap-instruction-opcode insn) nil) + insn) + (%make-lap-instruction form)))) + +;;; FORM is a list and its car isn't a pseudo-op or lapmacro; try to +;;; generate an instruction. +(defun assemble-instruction (seg form) + (let* ((insn (make-lap-instruction form))) (destructuring-bind (name . opvals) form (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name) @@ -614,5 +986,4 @@ (error "Can't use explicit condition and :? : ~s" condform) (setq cond c)))))) - (let* ((optypes (arm-instruction-template-operand-types template)) (n (length optypes))) @@ -628,5 +999,5 @@ (setf (lap-instruction-opcode insn) (dpb cond (byte 4 28) (lap-instruction-opcode insn)))) - insn))))) + (ccl::append-dll-node insn seg)))))) ;;; A label can only be emitted once. Once it's been emitted, its pred/succ @@ -669,3 +1040,82 @@ lab)) +(defun emit-lap-label (seg name) + (let* ((lab (find-lap-label name))) + (if lab + (when (lap-label-emitted-p lab) + (error "Label ~s: multiply defined." name)) + (setq lab (make-lap-label name))) + (ccl::append-dll-node lab seg))) + +(defmacro do-lap-labels ((lab &optional result) &body body) + (let* ((thunk-name (gensym)) + (k (gensym)) + (xlab (gensym))) + `(flet ((,thunk-name (,lab) ,@body)) + (if (listp *lap-labels*) + (dolist (,xlab *lap-labels*) + (,thunk-name ,xlab)) + (maphash #'(lambda (,k ,xlab) + (declare (ignore ,k)) + (,thunk-name ,xlab)) + *lap-labels*)) + ,result))) + +(defun set-element-addresses (start seg) + (ccl::do-dll-nodes (element seg start) + (setf (instruction-element-address element) start) + (incf start (instruction-element-size element)))) + +(defun count-element-sizes (seg) + (let* ((start 0)) + (ccl::do-dll-nodes (element seg start) + (incf start (instruction-element-size element))))) + +(defun arm-finalize (primary constant-pool) + (dolist (lab *called-subprim-jmp-labels*) + (unless (lap-label-emitted-p lab) + (ccl::append-dll-node lab primary) + (assemble-instruction primary `(ba ,(lap-label-name lab))))) + (let* ((constants-size (count-element-sizes constant-pool))) + (unless (eql constants-size 0) + (let* ((c0 (make-lap-instruction nil))) + (setf (lap-instruction-opcode c0) (ash constants-size -2)) + (ccl::insert-dll-node-before c0 (ccl::dll-header-first constant-pool))))) + (let* ((w0 (make-lap-instruction nil)) + (w1 (make-lap-instruction nil))) + (setf (lap-instruction-opcode w0) 0) + (ccl::append-dll-node w0 primary) + (ccl::append-dll-node w1 primary ) + (let* ((n (set-element-addresses 0 primary))) + (setf (lap-instruction-opcode w1) n) + (set-element-addresses n constant-pool))) + ;; Now fix up label references. Recall that the PC value at some + ;; point in program execution is 8 bytes beyond that point. + (do-lap-labels (lab) + (if (lap-label-emitted-p lab) + (let* ((labaddr (lap-label-address lab))) + (dolist (ref (lap-label-refs lab)) + (destructuring-bind (insn . reftype) ref + (let* ((diff-in-bytes (- labaddr (+ 8 (lap-instruction-address insn))))) + (case reftype + (:b (setf (lap-instruction-opcode insn) + (dpb (ash diff-in-bytes -2) + (byte 24 0) + (lap-instruction-opcode insn)))) + (:mem12 + (if (>= diff-in-bytes 0) + (set-field-value insn (byte 1 23) 1) + (setq diff-in-bytes (- diff-in-bytes))) + (set-field-value insn (byte 12 0) diff-in-bytes)) + (t + (error "Label type ~s invalid or not yet supported." + reftype))))))) + (if (lap-label-refs lab) + (error "LAP label ~s was referenced but not defined." (lap-label-name lab))))) + (ccl::merge-dll-nodes primary constant-pool) + (let* ((last (ccl::dll-header-last primary))) + (ash (+ (instruction-element-address last) + (instruction-element-size last)) -2))) + + (provide "ARM-ASM") Index: /branches/arm/compiler/ARM/arm-disassemble.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-disassemble.lisp (revision 13707) +++ /branches/arm/compiler/ARM/arm-disassemble.lisp (revision 13707) @@ -0,0 +1,341 @@ +;;;-*- Mode: Lisp; Package: (ARM :use CL) -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(eval-when (:compile-toplevel :load-toplevel :execute) +(require "ARM-ASM") +) + +(defstruct (arm-disassembled-instruction (:conc-name adi-)) + (opcode 0 :type (unsigned-byte 32)) + (labeled nil) + (mnemonic nil) + (condition-name nil) + (operands nil)) + +(defun arm-gpr-name (regno) + `(:gpr ,regno)) + + + +(defun find-arm-instruction-template (opcode) + (dotimes (i (length arm::*arm-instruction-table*)) + (let* ((template (svref arm::*arm-instruction-table* i)) + (value (arm::arm-instruction-template-val template)) + (masks (arm::arm-instruction-template-mask-list template))) + (if + (if (atom masks) + (= (logand opcode masks) value) + (dolist (mask masks) + (if (atom mask) + (if (= (logand opcode mask) value) + (return t)) + (if (= (logand opcode (cdr mask)) (car mask)) + (return t))))) + (return template))))) + + +(defun extract-arm-rd-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (arm-gpr-name (ldb (byte 4 12) opcode)))) + +(defun extract-arm-rn-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (arm-gpr-name (ldb (byte 4 16) opcode)))) + +(defparameter *arm-shift-ops* #(:lsl :lsr :asr :ror)) + + +(defun extract-arm-shifter-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (if (logbitp 25 opcode) + (let* ((count (ash (ldb (byte 4 8) opcode) 1))) + `(:$ ,(arm::arm-rotate-left (ldb (byte 8 0) opcode) (logand 31 (- 32 count))))) + (let* ((rn (arm-gpr-name (ldb (byte 4 0) opcode))) + (register-shifted (logbitp 4 opcode))) + (if register-shifted + `(,(svref *arm-shift-ops* (ldb (byte 2 5) opcode)) + ,rn + ,(arm-gpr-name (ldb (byte 4 8) opcode))) + (let* ((shift-type (ldb (byte 2 5) opcode)) + (shift-count (ldb (byte 5 7) opcode))) + (if (and (eql shift-type 0) + (eql shift-count 0)) + rn + (if (and (eql shift-type 3) + (eql shift-count 0)) + `(:rrx ,rn) + `(,(svref *arm-shift-ops* shift-type) + ,rn + (:$ ,shift-count)))))))))) + + + +(defun extract-arm-m12-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (let* ((immediate (not (logbitp 25 opcode))) + (disp (ldb (byte 12 0) opcode)) + (p (logbitp 24 opcode)) + (u (logbitp 23 opcode)) + (w (logbitp 21 opcode)) + (rnval (ldb (byte 4 16) opcode)) + (rn (arm-gpr-name rnval))) + (cond (immediate + (unless u (setq disp (- disp))) + (if (and u + p + (not w) + (eql arm::fn rnval) + (eql (mod (- disp arm::misc-data-offset) 4) 0)) + `(:@ ,rn (:constant ,(ash (- disp arm::misc-data-offset) -2))) + (if (and p (not w) (eql arm::pc rnval) (not (logtest 3 disp))) + (let* ((target (+ i 2 (ash disp -2)))) + (when (< target (uvsize opcodes)) + (setf (adi-labeled (uvref opcodes target)) t)) + `(:= (:label ,target))) + (if p + (if w + `(:@! ,rn (:$ ,disp)) + `(:@ ,rn (:$ ,disp))) + `(:@+ ,rn (:$ ,disp)))))) + (t + (let* ((shift-op (ldb (byte 2 5) opcode)) + (shift-count (ldb (byte 5 7) opcode)) + (rm (arm-gpr-name (ldb (byte 4 0) opcode))) + (memop + (if p + (if w + (if u :+@! :-@!) + (if u :+@ :-@)) + (if u :@+ :@-)))) + (if (and (zerop shift-count) (zerop shift-op)) + `(,memop ,rn ,rm) + (if (and (eql 3 shift-op) (zerop shift-count)) + `(,memop ,rn (:rrx ,rm)) + `(,memop ,rn (,(svref *arm-shift-ops* shift-op) + ,rm + (:$ ,shift-count))))))))))) + + +(defun extract-arm-reglist-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (let* ((mask (ldb (byte 16 0) opcode)) + (regs ())) + (declare (type (unsigned-byte 16) i)) + (do* ((i 15 (1- i))) + ((< i 0) `(:reglist ,regs)) + (declare ((signed-byte 4) i)) + (when (logbitp i mask) + (push i regs)))))) + +(defun extract-arm-rnw-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (let* ((regname (arm-gpr-name (ldb (byte 4 16) opcode)))) + (if (logbitp 21 opcode) + `(:! ,regname) + regname)))) + +(defun extract-arm-uuoa-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (arm-gpr-name (ldb (byte 4 8) opcode)))) + +(defun extract-arm-uuo-unary-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + `(:$ ,(ldb (byte 8 12) opcode)))) + +(defun extract-arm-uuob-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (arm-gpr-name (ldb (byte 4 12) opcode)))) + +(defun extract-arm-rm-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (arm-gpr-name (ldb (byte 4 0) opcode)))) + +(defun extract-arm-b-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i))) + (b-field (ldb (byte 24 0) opcode))) + (when (logbitp 23 b-field) + (setq b-field (- b-field (ash 1 24)))) + (let* ((target (+ i 2 b-field))) + (when (and (>= target 0) + (< target (length opcodes))) + (setf (adi-labeled (svref opcodes target)) t)) + `(:label ,target)))) + +(defun extract-arm-subprim-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i))) + (count (ash (ldb (byte 4 8) opcode) 1)) + (spaddr (arm::arm-rotate-left (ldb (byte 8 0) opcode) (logand 31 (- 32 count)))) + (name (arm::arm-subprimitive-name spaddr))) + (if name + `(:spname ,name) + `(:$ ,spaddr)))) + +(defun extract-arm-m8-operand (opcodes i) + (let* ((opcode (adi-opcode (svref opcodes i)))) + (let* ((immediate (not (logbitp 25 opcode))) + (disp (dpb (ldb (byte 4 8) opcode) + (byte 4 4) + (ldb (byte 4 0) opcode))) + (p (logbitp 24 opcode)) + (u (logbitp 23 opcode)) + (w (logbitp 21 opcode)) + (rnval (ldb (byte 4 16) opcode)) + (rn (arm-gpr-name rnval))) + (cond (immediate + (unless u (setq disp (- disp))) + (if p + (if w + `(:@! ,rn (:$ ,disp)) + `(:@ ,rn (:$ ,disp))) + `(:@+ ,rn (:$ ,disp)))) + (t + (let* ((rm (arm-gpr-name (ldb (byte 4 0) opcode)))) + `(,(if p + (if w + (if u :+@! :-@!) + (if u :+@ :-@)) + (if u :@+ :@-)) ,rn ,rm))))))) + +(defparameter *arm-operand-extract-functions* + #(extract-arm-rd-operand + extract-arm-rn-operand + extract-arm-shifter-operand + extract-arm-m12-operand + extract-arm-reglist-operand + extract-arm-rnw-operand + extract-arm-uuoa-operand + extract-arm-uuo-unary-operand + extract-arm-uuob-operand + extract-arm-rm-operand + extract-arm-b-operand + extract-arm-subprim-operand + extract-arm-m8-operand + )) + +(defun make-adi-vector (code-vector) + (let* ((n (uvsize code-vector)) + (v (make-array n))) + (declare (fixnum n) (simple-vector v)) + (dotimes (i n v) + (setf (svref v i) + (make-arm-disassembled-instruction :opcode (uvref code-vector i)))))) + +(defun process-adi-vector (adi-vector) + (let* ((n (length adi-vector)) + (skip 0) + (data 0)) + (dotimes (i n adi-vector) + (let* ((adi (svref adi-vector i)) + (opcode (adi-opcode adi))) + (cond ((> skip 0) + (decf skip) + (if (= skip 0) + (setq data opcode))) + ((> data 0) + (decf data) + (setf (adi-mnemonic adi) ":word" + (adi-operands adi) (list opcode))) + ((= opcode 0) + (setq skip 2)) + (t + (let* ((template (find-arm-instruction-template opcode))) + (if (null template) + (setf (adi-mnemonic adi) :??? + (adi-operands adi) (list opcode)) + (collect ((operands)) + (setf (adi-mnemonic adi) + (arm::arm-instruction-template-name template)) + (unless (logtest (arm::encode-arm-instruction-flag :non-conditional) (arm::arm-instruction-template-flags template)) + (let* ((cond (ldb (byte 4 28) opcode)) + (cond-name (if (< cond 14) (arm::lookup-arm-condition-value cond)))) + (when cond-name + (if (logtest (arm::encode-arm-instruction-flag :prefer-separate-cond) (arm::arm-instruction-template-flags template)) + (operands `(:? ,cond-name)) + (setf (adi-condition-name adi) cond-name))))) + + (dolist (type (arm::arm-instruction-template-operand-types template)) + (operands (funcall (svref *arm-operand-extract-functions* type) adi-vector i))) + (setf (adi-operands adi) (operands))))))))))) + +(defparameter *arm-gpr-names* + #("imm0" "imm1" "nargs" "rcontext" "arg_z" "arg_y" "arg_x" "temp0" + "temp1" "temp2" "vsp" "fn" "allocptr" "sp" "lr" "pc")) + +(defun disassemble-arm-xfunction (xfunction &optional (stream *debug-io*)) + (let* ((adi-vector (process-adi-vector (make-adi-vector (uvref xfunction 1))))) + (dotimes (i (length adi-vector)) + (let* ((info (svref adi-vector i))) + (when (adi-labeled info) + (format stream "~&L~d~&" (ash i 2))) + (let* ((name (adi-mnemonic info))) + (when name + (let* ((condition-name (or (adi-condition-name info) ""))) + (format stream "~& (~a~a" name condition-name)) + (labels ((format-operand (operand) + (write-char #\space stream) + (if (atom operand) + (if (and (typep operand 'integer) + (> (abs operand) 100)) + (format stream "#x~x" operand) + (format stream "~d" operand)) + (ecase (car operand) + (:= (format stream "(:=") + (format-operand (cadr operand)) + (write-char #\) stream)) + (:label (format stream "L~d" (ash (cadr operand) 2))) + (:constant (format stream "~s" (list 'quote (uvref xfunction (cadr operand))))) + ((:lsl :lsr :asr :ror :rrx) + (format stream "(~s" (car operand)) + (dolist (sub (cdr operand)) + (format-operand sub)) + (write-char #\) stream)) + (:spname + (let* ((string (string (cadr operand))) + (n (length string)) + (copy (make-string n))) + (declare (dynamic-extent copy)) + (dotimes (i n (format stream "~a" copy)) + (let* ((ch (char string i))) + (setf (schar copy i) + (if (< i 3) + ch + (char-downcase ch))))))) + (:$ (format stream "(:$") + (format-operand (cadr operand)) + (write-char #\) stream)) + (:? (format stream "(:? ~a)" (cadr operand))) + (:gpr (format stream "~a" (svref *arm-gpr-names* (cadr operand)))) + (:reglist (format stream "~a" + (mapcar (lambda (r) + (svref *arm-gpr-names* r)) + (cadr operand)))) + ((:@ :@! :+@ :+@! :-@ :-@! :@+ :@-) + (format stream "(~s" (car operand)) + (dolist (sub (cdr operand)) + (format-operand sub)) + (write-char #\) stream)) + (:! + (format stream "(:!") + (format-operand (cadr operand)) + (write-char #\) stream)))))) + (dolist (op (adi-operands info)) + (format-operand op)) + (write-char #\) stream)))))))) + + + + + Index: /branches/arm/compiler/ARM/arm-lap.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-lap.lisp (revision 13706) +++ /branches/arm/compiler/ARM/arm-lap.lisp (revision 13707) @@ -41,24 +41,8 @@ ',name)) -(defvar *arm-lap-constants* ()) -(defvar *arm-lap-regsave-reg* ()) -(defvar *arm-lap-regsave-addr* ()) -(defvar *arm-lap-regsave-label* ()) (defvar *arm-lap-lfun-bits* 0) -(defmacro do-lap-labels ((lab &optional result) &body body) - (let* ((thunk-name (gensym)) - (k (gensym)) - (xlab (gensym))) - `(flet ((,thunk-name (,lab) ,@body)) - (if (listp arm::*lap-labels*) - (dolist (,xlab arm::*lap-labels*) - (,thunk-name ,xlab)) - (maphash #'(lambda (,k ,xlab) - (declare (ignore ,k)) - (,thunk-name ,xlab)) - arm::*lap-labels*)) - ,result))) + @@ -77,101 +61,34 @@ (defun %define-arm-lap-function (name body &optional (bits 0)) - (with-dll-node-freelist (*lap-instructions* arm::*lap-instruction-freelist*) - (let* ((*lap-labels* ()) + (with-dll-node-freelist (primary arm::*lap-instruction-freelist*) + (with-dll-node-freelist (constant-pool arm::*lap-instruction-freelist*) + (let* ((arm::*lap-labels* ()) (arm::*arm-constants* ()) - (*arm-lap-lfun-bits* bits)) + (*arm-lap-lfun-bits* bits) + (arm::*arm-register-names* arm::*standard-arm-register-names*) + (arm::*called-subprim-jmp-labels* ()) + (current primary) + (sections (vector primary constant-pool))) + (declare (dynamic-extent sections)) (dolist (form body) - (arm-lap-form form)) - (arm-lap-generate-code name (arm-lap-do-labels) *arm-lap-lfun-bits*)))) - - - -(defun arm-lap-assign-addresses (delete-labels-p) - (let* ((pc 0)) - (declare (fixnum pc)) - (do-dll-nodes (node *lap-instructions*) - (setf (arm::instruction-element-address node) pc) - (if (typep node 'arm::lap-label) - (if delete-labels-p (remove-dll-node node)) - (incf pc 4))) - ;; Don't bother checking code-vector size yet. - pc)) - - - -(defun arm-lap-do-labels () - (do-lap-labels (lab) - (if (and (arm::lap-label-refs lab) (not (arm::lap-label-emitted-p lab))) - (error "Label ~S was referenced but never defined. " - (arm::lap-label-name lab))) - ;; Repeatedly iterate through label's refs, until none of them is - ;; the preceding instruction. This eliminates - ;; (b @next) - ;;@next - ;; - ;; but can probably be fooled by hairier nonsense. - (loop - (when (dolist (ref (arm::lap-label-refs lab) t) - (when (eq lab (arm::lap-instruction-succ ref)) - (remove-dll-node ref) - (setf (arm::lap-label-refs lab) (delete ref (arm::lap-label-refs lab))) - (return))) - (return)))) - ;; Assign pc to emitted labels, splice them out of the list. - - (arm-lap-assign-addresses t)) - -;;; Replace each label with the difference between the label's address -;;; and the referencing instruction's address. -(defun arm-lap-resolve-labels () - (do-lap-labels (label) - (let* ((label-address (arm::lap-label-address label))) - (declare (fixnum label-address)) ; had BETTER be ... - (dolist (insn (arm::lap-label-refs label)) - (let* ((diff (- label-address (arm::lap-instruction-address insn)))) - (declare (fixnum diff)) - (let* ((opvals (arm::lap-instruction-parsed-operands insn)) - (pos (position label opvals))) - (unless pos - (error "Bug: label ~s should be referenced by instruction ~s, but isn't." label insn)) - (setf (svref opvals pos) diff))))))) - -(defun arm-lap-generate-instruction (code-vector index insn) - (let* ((op (arm::lap-instruction-opcode insn)) - (vals (lap-instruction-parsed-operands insn)) - (high (opcode-op-high op)) - (low (opcode-op-low op)) - (idx -1)) - (dolist (operand (opcode-operands op)) - (let* ((val (if (logbitp operand-fake (operand-flags operand)) - 0 - (svref vals (incf idx)))) - (insert-function (operand-insert-function operand))) - (multiple-value-setq (high low) - (if insert-function - (funcall insert-function high low val) - (arm::insert-default operand high low val))) - (if (null high) - (error "Invalid operand for ~s instruction: ~d" (opcode-name op) val)))) - (setf (lap-instruction-parsed-operands insn) nil) - (free-lap-operand-vector vals) - (locally (declare (type (simple-array (unsigned-byte 16) (*)) code-vector) - (optimize (speed 3) (safety 0))) - (setf (aref code-vector (+ index index)) high - (aref code-vector (+ index index 1)) low) - nil))) - - - -(defun arm-lap-generate-code (name maxpc bits) - (declare (fixnum maxpc)) + (setq current (arm-lap-form form current sections))) + (arm-lap-generate-code name + primary + (arm::arm-finalize primary constant-pool) + *arm-lap-lfun-bits*))))) + + + + + + + +(defun arm-lap-generate-code (name seg code-vector-size bits) + (declare (fixnum code-vector-size)) (let* ((target-backend *target-backend*) - (cross-compiling (not (eq *host-backend* target-backend))) - - (prefix (arch::target-code-vector-prefix (backend-target-arch *target-backend*))) - (prefix-size (length prefix)) - (code-vector-size (+ (ash maxpc -2) prefix-size)) - - (constants-size (+ 4 (length *arm-lap-constants*))) + (cross-compiling (target-arch-case + (:arm (not (eq *host-backend* target-backend))) + (t t))) + (constants-size (+ 4 (length arm::*arm-constants*))) (constants-vector (%alloc-misc constants-size @@ -179,5 +96,5 @@ target::subtag-xfunction target::subtag-function))) - (i prefix-size)) + (i 0)) (declare (fixnum i constants-size)) (let* ((code-vector (%alloc-misc @@ -186,34 +103,65 @@ target::subtag-xcode-vector arm::subtag-code-vector)))) - (dotimes (j prefix-size) - (setf (uvref code-vector j) (pop prefix))) - (arm-lap-resolve-labels) ; all operands fully evaluated now. - (do-dll-nodes (insn *lap-instructions*) - (arm-lap-generate-instruction code-vector i insn) - (incf i)) - - (dolist (immpair *arm-lap-constants*) + (do-dll-nodes (insn seg) + (unless (eql (arm::instruction-element-size insn) 0) + (setf (uvref code-vector i) (arm::lap-instruction-opcode insn)) + (incf i))) + (dolist (immpair arm::*arm-constants*) (let* ((imm (car immpair)) (k (cdr immpair))) (declare (fixnum k)) - (setf (uvref constants-vector - (ash - (- k (arch::target-misc-data-offset (backend-target-arch target-backend))) - (- (arch::target-word-shift (backend-target-arch target-backend))))) - imm))) + (setf (uvref constants-vector (+ 2 k)) imm))) (setf (uvref constants-vector (1- constants-size)) bits ; lfun-bits (uvref constants-vector (- constants-size 2)) name - (uvref constants-vector 0) code-vector) + (uvref constants-vector 1) code-vector) #+arm-target (%make-code-executable code-vector) constants-vector))) -(defun arm-lap-pseudo-op (form) - (case (car form) - (:arglist (setq *arm-lap-lfun-bits* (encode-lambda-list (cadr form)))))) - +(defun arm-lap-pseudo-op (directive arg current sections) + (flet ((check-usage (directive) + (unless (eq current (svref sections 1)) + (error "~s directive should only be used inside :data section" directive)))) + (ecase directive + (:arglist (setq *arm-lap-lfun-bits* (encode-lambda-list arg))) + (:data + (setq current (svref sections 1))) + (:text + (setq current (svref sections 0))) + (:section + (setq current (svref sections + (ecase arg + (:text 0) + (:data 1))))) + (:word + (check-usage :word) + (append-dll-node + (let* ((insn (arm::make-lap-instruction nil))) + (setf (arm::lap-instruction-opcode insn) (logand #xffffffff (eval arg))) + insn) + current)) + + (:single + (check-usage :single) + (append-dll-node + (let* ((insn (arm::make-lap-instruction nil))) + (setf (arm::lap-instruction-opcode insn) (single-float-bits (float (eval arg) 0.0f0))) + insn) + current)) + (:double + (check-usage :double) + (multiple-value-bind (high low) (double-float-bits (float (eval arg) 0.0d0)) + (let* ((insnlow (arm::make-lap-instruction nil)) + (insnhigh (arm::make-lap-instruction nil))) + (setf (arm::lap-instruction-opcode insnlow) low + (arm::lap-instruction-opcode insnhigh) high) + (append-dll-node insnlow current) + (append-dll-node insnhigh current))))) + current)) -(defun arm-lap-form (form) + + +(defun arm-lap-form (form current sections) (if (and form (symbolp form)) - (emit-lap-label form) + (arm::emit-lap-label current form) (if (or (atom form) (not (symbolp (car form)))) (error "~& unknown ARM-LAP form: ~S ." form) @@ -221,18 +169,19 @@ (arm-lap-macroexpand-1 form) (if expanded - (arm-lap-form expansion) + (setq current (arm-lap-form expansion current sections)) (let* ((name (car form))) (if (keywordp name) - (arm-lap-pseudo-op form) + (setq current (arm-lap-pseudo-op name (cadr form) current sections)) (case name - ((progn) (dolist (f (cdr form)) (arm-lap-form f))) - ((let) (arm-lap-equate-form (cadr form) (cddr form))) + ((progn) (dolist (f (cdr form)) (setq current (arm-lap-form f current sections)))) + ((let) (setq current (arm-lap-equate-form (cadr form) (cddr form) current sections))) (t - (arm-lap-instruction name (cdr form))))))))))) + (arm::assemble-instruction current form))))))))) + current) ;;; (let ((name val) ...) &body body) ;;; each "val" gets a chance to be treated as a ARM register name ;;; before being evaluated. -(defun arm-lap-equate-form (eqlist body) +(defun arm-lap-equate-form (eqlist body current sections) (collect ((symbols) (values)) @@ -245,5 +194,8 @@ (not (arm::get-arm-register symbol))) (error "~s is not a bindable symbol name . " symbol)) - (let* ((regval (arm::get-arm-register value))) + (let* ((regval (and value + (or (typep value 'symbol) + (typep value 'string)) + (arm::get-arm-register value)))) (if regval (arm::define-arm-register symbol regval) @@ -253,218 +205,11 @@ (progv (symbols) (values) - (dolist (form body) - (arm-lap-form form)))))) - -(defun arm-lap-constant-offset (x) - (or (cdr (assoc x *arm-lap-constants* :test #'equal)) - (let* ((target-backend *target-backend*) - (n (+ (arch::target-misc-data-offset (backend-target-arch target-backend)) - (ash (1+ (length *arm-lap-constants*)) - (arch::target-word-shift (backend-target-arch target-backend)))))) - (push (cons x n) *arm-lap-constants*) - n))) - -; Evaluate an arbitrary expression; warn if the result isn't a fixnum. -(defun arm-lap-evaluated-expression (x) - (if (typep x 'fixnum) - x - (if (null x) - (arch::target-nil-value (backend-target-arch *target-backend*)) - (if (eq x t) - (+ (arch::target-nil-value (backend-target-arch *target-backend*)) - (arch::target-t-offset (backend-target-arch *target-backend*))) - (let* ((val (handler-case (eval x) ; Look! Expression evaluation! - (error (condition) (error "~&Evaluation of ~S signalled assembly-time error ~& ~A ." - x condition))))) - (unless (typep val 'fixnum) - (warn "assembly-time evaluation of ~S returned ~S, which may not have been intended ." - x val)) - val))))) - -(defparameter *arm-lap-register-aliases* - `((nfn . ,arm::nfn) - (fname . ,arm::fname))) - -(defparameter *arm-lap-fp-register-aliases* - ()) - -(defparameter *arm-lap-vector-register-aliases* - ()) - -(defun arm-gpr-name-p (x) - (and (or (symbolp x) (stringp x)) - (or - (position (string x) arm::*gpr-register-names* :test #'string-equal) - (cdr (assoc x *arm-lap-register-aliases* :test #'string-equal))))) - -(defun arm-register-name-or-expression (x) - (if x - (or (arm-gpr-name-p x) - (if (and (consp x) (eq (car x) 'quote)) - (let* ((quoted-form (cadr x))) - (if (null quoted-form) - (arch::target-nil-value (backend-target-arch *target-backend*)) - (if (eq quoted-form t) - (+ (arch::target-nil-value (backend-target-arch *target-backend*)) - (arch::target-t-offset (backend-target-arch *target-backend*))) - (if (typep quoted-form 'fixnum) - (ash quoted-form (arch::target-fixnum-shift (backend-target-arch *target-backend*))) - (arm-lap-constant-offset quoted-form))))) - (arm-lap-evaluated-expression x))) - (arch::target-nil-value (backend-target-arch *target-backend*)))) - -(defun arm-fpr-name-p (x) - (and (or (symbolp x) (stringp x)) - (or - (position (string x) arm::*fpr-register-names* :test #'string-equal) - (cdr (assoc x *arm-lap-fp-register-aliases* :test #'string-equal))))) - -(defun arm-fp-register-name-or-expression (x) - (or (arm-fpr-name-p x) - (arm-lap-evaluated-expression x))) - -(defun arm-vr-name-p (x) - (and (or (symbolp x) (stringp x)) - (or - (position (string x) arm::*vector-register-names* :test #'string-equal) - (cdr (assoc x *arm-lap-vector-register-aliases* :test #'string-equal))))) - -(defun arm-vector-register-name-or-expression (x) - (or (arm-vr-name-p x) - (arm-lap-evaluated-expression x))) - - -(defparameter *arm-cr-field-names* #(:crf0 :crf1 :crf2 :crf3 :crf4 :crf5 :crf6 :crf7)) -(defparameter *arm-cr-names* #(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7)) -(defparameter *arm-cc-bit-names* #(:lt :gt :eq :so :un)) -(defparameter *arm-cc-bit-inverse-names* #(:ge :le :ne :ns :nu)) - -; This wants a :CC, a negated :CC, or either (:CRn :CC) or (:CRn :~CC). -; Returns the fully-qualified CR bit and an indication of whether or not the CC was -; negated. -(defun arm-lap-parse-test (x) - (if (or (symbolp x) (stringp x)) - (let* ((pos (position x *arm-cc-bit-names* :test #'string-equal))) - (if pos - (values (min pos 3) nil) - (if (setq pos (position x *arm-cc-bit-inverse-names* :test #'string-equal)) - (values (min pos 3) t) - (error "Unknown ARM lap condition form : ~s" x)))) - (if (and (consp x) (keywordp (car x)) (consp (cdr x)) (keywordp (cadr x))) - (let* ((field (position (car x) *arm-cr-names*))) - (unless field (error "Unknown CR field name : ~s" (car x))) - (let* ((bit (position (cadr x) *arm-cc-bit-names*))) - (if bit - (values (logior (ash field 2) (min bit 3)) nil) - (if (setq bit (position (cadr x) *arm-cc-bit-inverse-names*)) - (values (logior (ash field 2) (min bit 3)) t) - (error "Unknown condition name : ~s" (cadr x)))))) - (error "Unknown ARM lap condition form : ~s" x)))) - -; Accept either :CRn, :CC, or (:CRFn :CC), or evaluate an expression. -(defun arm-lap-cr-field-expression (x) - (if (or (symbolp x) (stringp x)) - (let* ((pos (position x *arm-cr-names* :test #'string-equal))) - (if pos - (ash pos 2) - (let* ((cc-pos (position x *arm-cc-bit-names* :test #'string-equal))) - (if cc-pos - (min cc-pos 3) - (arm-lap-evaluated-expression x))))) - (if (and (consp x) (keywordp (car x)) (consp (cdr x)) (keywordp (cadr x))) - (let* ((field (position (car x) *arm-cr-field-names*)) - (bit (position (cadr x) *arm-cc-bit-names*))) - (if (and field bit) - (logior (min bit 3) (ash field 2)) - (error "Bad arm-cr-field-expression: ~s" x))) - (arm-lap-evaluated-expression x)))) - -(defun arm-lap-instruction (name opvals) - (let* ((opnum (gethash (string name) arm::*arm-opcode-numbers*)) - (opcode (and opnum - (< -1 opnum (length arm::*arm-opcodes*)) - (svref arm::*arm-opcodes* opnum)))) - (unless opcode - (error "Unknown ARM opcode: ~a" name)) - ;; Unless either - ;; a) The number of operand values in the macro call exactly - ;; matches the number of operands accepted by the instruction or - ;; b) The number of operand values is one less, and the instuction - ;; takes an optional operand - ;; we've got a wrong-number-of-args error. - ;; In case (b), there's at most one optional argument per instruction; - ;; provide 0 for the missing value. - (let* ((operands (opcode-operands opcode)) - (nmin (opcode-min-args opcode)) - (nmax (opcode-max-args opcode)) - (nhave (length opvals))) - (declare (fixnum nmin nmax nhave)) - (if (= nhave nmax) - (arm-emit-lap-instruction opcode opvals) - (if (> nhave nmax) - (error "Too many operands in ~s (~a accepts at most ~d)" - opvals name nmax) - (if (= nhave nmin) - (let* ((newops ())) - (dolist (op operands (arm-emit-lap-instruction opcode (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)" - opvals name nmin))))))) - -; This is pretty rudimentary: if the operand has the "arm::$arm-operand-relative" bit -; set, we demand a label name and note the fact that we reference the label in question. -; Otherwise, we use the "register-name-or-expression" thing. -; Like most ARM assemblers, this lets you treat everything as an expression, even if -; you've got the order of some arguments wrong ... - -(defun arm-parse-lap-operand (opvalx operand insn) - (let* ((flags (operand-flags operand))) - (declare (fixnum flags)) - (if (logbitp arm::$arm-operand-relative flags) - (lap-note-label-reference opvalx insn) - (if (logbitp arm::$arm-operand-cr flags) - (arm-lap-cr-field-expression opvalx) - (if (logbitp arm::$arm-operand-absolute flags) - (arm-subprimitive-address opvalx) - (if (logbitp arm::$arm-operand-fpr flags) - (arm-fp-register-name-or-expression opvalx) - (if (logbitp arm::$arm-operand-vr flags) ; SVS - (arm-vector-register-name-or-expression opvalx) - (arm-register-name-or-expression opvalx)))))))) - -(defun arm-subprimitive-address (x) - (if (and x (or (symbolp x) (stringp x))) - (let* ((info (find x arm::*arm-subprims* :test #'string-equal :key #'subprimitive-info-name))) - (when info (return-from arm-subprimitive-address - (subprimitive-info-offset info))))) - (arm-lap-evaluated-expression x)) - - -;;; We've checked that the number of operand values match the number -;;; expected (and have set "fake" operand values to 0.) Labels - and -;;; some constructs that might someday do arithmetic on them - are -;;; about the only class of forward references we need to deal with. -;;; This whole two-pass scheme seems overly general, but if/when we -;;; ever do instruction scheduling it'll probably make it simpler. -(defun arm-emit-lap-instruction (opcode opvals) - (let* ((operands (opcode-operands opcode)) - (parsed-values (alloc-lap-operand-vector)) - (insn (make-lap-instruction opcode)) - (idx -1)) - (declare (fixnum idx)) - (dolist (op operands) - (let* ((flags (operand-flags op)) - (val (if (logbitp operand-fake flags) - 0 - (arm-parse-lap-operand (pop opvals) op insn)))) - (declare (fixnum flags)) - (setf (svref parsed-values (incf idx)) val))) - (setf (lap-instruction-parsed-operands insn) parsed-values) - (append-dll-node insn *lap-instructions*))) + (dolist (form body current) + (setq current (arm-lap-form form current sections))))))) + + + + + Index: /branches/arm/compiler/ARM/arm-lapmacros.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-lapmacros.lisp (revision 13706) +++ /branches/arm/compiler/ARM/arm-lapmacros.lisp (revision 13707) @@ -44,5 +44,5 @@ (uuo-error-wrong-nargs (:? lo)) (cmp nargs ($ (ash ,max arm::fixnumshift))) - (uuo-error-wrong-nargs (:? hi))))))) + (uuo-error-wrong-nargs (:? hi))))))) @@ -78,8 +78,8 @@ (defarmlapmacro pop1 (dest stack) - `(ldr ,dest (:@+ ,stack (:% arm::node-size)))) + `(ldr ,dest (:@+ ,stack (:$ arm::node-size)))) (defarmlapmacro vpop1 (dest) - `(pop ,dest vsp)) + `(pop1 ,dest vsp)) (defarmlapmacro %cdr (dest node) @@ -107,11 +107,15 @@ (ldrbeq ,dest (:@ ,node (:$ arm::misc-subtag-offset))))) +;;; Set the EQ bit if NODE is a fixnum +(defarmlapmacro test-fixnum (node) + `(tst ,node (:$ arm::tagmask))) + (defarmlapmacro trap-unless-fixnum (node) `(progn - (tst node (:$ arm::tagmask)) - (uuo-error-reg-not-lisptag (:? ne) node (:$ arm::tag-fixnum)))) - - -(defarmlapmacro trap-unless-lisptag= (node tag &optional (immreg imm0)) + (test-fixnum ,node) + (uuo-error-reg-not-lisptag (:? ne) ,node (:$ arm::tag-fixnum)))) + + +(defarmlapmacro trap-unless-lisptag= (node tag &optional (immreg 'imm0)) `(progn (extract-lisptag ,immreg ,node) @@ -119,5 +123,5 @@ (uuo-error-reg-not-lisptag (:? ne) ,node (:$ ,tag)))) -(defarmlapmacro trap-unless-fulltag= (node tag &optional (immreg imm0)) +(defarmlapmacro trap-unless-fulltag= (node tag &optional (immreg 'imm0)) `(progn (extract-fulltag ,immreg ,node) @@ -126,5 +130,5 @@ -(defarmlapmacro trap-unless-xtype= (node tag &optional (immreg imm0)) +(defarmlapmacro trap-unless-xtype= (node tag &optional (immreg 'imm0)) `(progn (extract-typecode ,immreg ,node) @@ -138,8 +142,9 @@ ;;; This is about as hard on the pipeline as anything I can think of. (defarmlapmacro call-symbol (function-name) - (load-constant fname ,function-name) - (ldr nfn (:@ fname (:$ arm::symbol.fname))) - (ldr lr (:@ nfn (:$ arm::function.entrypoint))) - (blx lr)) + `(progn + (load-constant fname ,function-name) + (ldr nfn (:@ fname (:$ arm::symbol.fname))) + (ldr lr (:@ nfn (:$ arm::function.entrypoint))) + (blx lr))) (defarmlapmacro sp-call-symbol (function-name) @@ -159,6 +164,6 @@ (defarmlapmacro header-length (dest vheader) `(progn - (mov ,dest (:$ (- arm::fixnumone))) - (and ,dest ,dest (:lsr ,src (:$ (- arm::num-subtag-bits arm::fixnumshift)))))) + (mov ,dest '-1) + (and ,dest ,dest (:lsr ,vheader (:$ (- arm::num-subtag-bits arm::fixnumshift)))))) @@ -186,5 +191,5 @@ (defarmlapmacro vref32 (dest miscobj index scaled-idx) `(progn - (add ,scaled-idex ,index (:$ arm::misc-data-offset)) + (add ,scaled-idx ,index (:$ arm::misc-data-offset)) (ldr ,dest (:@ ,miscobj ,scaled-idx)))) @@ -192,5 +197,5 @@ (defarmlapmacro vset32 (src miscobj index scaled-idx) `(progn - (add ,scaled-idex ,index (:$ arm::misc-data-offset)) + (add ,scaled-idx ,index (:$ arm::misc-data-offset)) (str ,src (:@ ,miscobj ,scaled-idx)))) @@ -210,6 +215,6 @@ `(progn ,@(if check - ((trap-unless-xtype= ,src arm::subtag-character ,dest))) - (mov ,dest ,src (:lsr arm::charcode-shift)))) + `((trap-unless-xtype= ,src arm::subtag-character ,dest))) + (mov ,dest ,src (:lsr (:$ arm::charcode-shift))))) @@ -256,5 +261,5 @@ `(progn (fmrs ,temp ,src) - (str ,temp (:@ ,node (:$ arm::single-float.value)))) + (str ,temp (:@ ,node (:$ arm::single-float.value))))) (defarmlapmacro put-double-float (src node) @@ -292,5 +297,5 @@ `(ldr ,dest (:@ ,macptr (:$ arm::macptr.address)))) -(defarmlapmacro svref (dest index vector)) +(defarmlapmacro svref (dest index vector) `(ldr ,dest (:@ ,vector (:$ (+ (* 4 ,index) arm::misc-data-offset))))) @@ -301,7 +306,5 @@ (defarmlapmacro vpush-argregs () - (let* ((none (gensym)) - (two (gensym)) - (one (gensym))) + (let* ((none (gensym))) `(progn (cmp nargs (:$ 0))