cpu.arm.assembler: dust it off, update to work with contemporary Factor, and clean it up a bit
Slava Pestov
parent
cb308e8cc8
commit
5fc3ad92f6
|
|
@ -1,8 +1,9 @@
|
|||
IN: cpu.arm.assembler.tests
|
||||
USING: assembler-arm math test namespaces sequences kernel
|
||||
quotations ;
|
||||
USING: cpu.arm.assembler math tools.test namespaces make
|
||||
sequences kernel quotations ;
|
||||
FROM: cpu.arm.assembler => B ;
|
||||
|
||||
: test-opcode [ { } make first ] curry unit-test ;
|
||||
: test-opcode ( expect quot -- ) [ { } make first ] curry unit-test ;
|
||||
|
||||
[ HEX: ea000000 ] [ 0 B ] test-opcode
|
||||
[ HEX: eb000000 ] [ 0 BL ] test-opcode
|
||||
|
|
@ -1,31 +1,46 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generator generator.fixup kernel sequences words
|
||||
namespaces math math.bitfields ;
|
||||
USING: accessors arrays combinators kernel make math math.bitwise
|
||||
namespaces sequences words words.symbol parser ;
|
||||
IN: cpu.arm.assembler
|
||||
|
||||
: define-registers ( seq -- )
|
||||
dup length [ "register" set-word-prop ] 2each ;
|
||||
! Registers
|
||||
<<
|
||||
|
||||
SYMBOL: R0
|
||||
SYMBOL: R1
|
||||
SYMBOL: R2
|
||||
SYMBOL: R3
|
||||
SYMBOL: R4
|
||||
SYMBOL: R5
|
||||
SYMBOL: R6
|
||||
SYMBOL: R7
|
||||
SYMBOL: R8
|
||||
SYMBOL: R9
|
||||
SYMBOL: R10
|
||||
SYMBOL: R11
|
||||
SYMBOL: R12
|
||||
SYMBOL: R13
|
||||
SYMBOL: R14
|
||||
SYMBOL: R15
|
||||
SYMBOL: registers
|
||||
|
||||
{ R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 }
|
||||
define-registers
|
||||
V{ } registers set-global
|
||||
|
||||
SYNTAX: REGISTER:
|
||||
CREATE-WORD
|
||||
[ define-symbol ]
|
||||
[ registers get length "register" set-word-prop ]
|
||||
[ registers get push ]
|
||||
tri ;
|
||||
|
||||
>>
|
||||
|
||||
REGISTER: R0
|
||||
REGISTER: R1
|
||||
REGISTER: R2
|
||||
REGISTER: R3
|
||||
REGISTER: R4
|
||||
REGISTER: R5
|
||||
REGISTER: R6
|
||||
REGISTER: R7
|
||||
REGISTER: R8
|
||||
REGISTER: R9
|
||||
REGISTER: R10
|
||||
REGISTER: R11
|
||||
REGISTER: R12
|
||||
REGISTER: R13
|
||||
REGISTER: R14
|
||||
REGISTER: R15
|
||||
|
||||
ALIAS: SL R10 ALIAS: FP R11 ALIAS: IP R12
|
||||
ALIAS: SP R13 ALIAS: LR R14 ALIAS: PC R15
|
||||
|
||||
<PRIVATE
|
||||
|
||||
PREDICATE: register < word register >boolean ;
|
||||
|
||||
|
|
@ -33,8 +48,7 @@ GENERIC: register ( register -- n )
|
|||
M: word register "register" word-prop ;
|
||||
M: f register drop 0 ;
|
||||
|
||||
: SL R10 ; inline : FP R11 ; inline : IP R12 ; inline
|
||||
: SP R13 ; inline : LR R14 ; inline : PC R15 ; inline
|
||||
PRIVATE>
|
||||
|
||||
! Condition codes
|
||||
SYMBOL: cond-code
|
||||
|
|
@ -46,43 +60,52 @@ SYMBOL: cond-code
|
|||
#! Default value is BIN: 1110 AL (= always)
|
||||
cond-code [ f ] change BIN: 1110 or ;
|
||||
|
||||
: EQ BIN: 0000 >CC ;
|
||||
: NE BIN: 0001 >CC ;
|
||||
: CS BIN: 0010 >CC ;
|
||||
: CC BIN: 0011 >CC ;
|
||||
: LO BIN: 0100 >CC ;
|
||||
: PL BIN: 0101 >CC ;
|
||||
: VS BIN: 0110 >CC ;
|
||||
: VC BIN: 0111 >CC ;
|
||||
: HI BIN: 1000 >CC ;
|
||||
: LS BIN: 1001 >CC ;
|
||||
: GE BIN: 1010 >CC ;
|
||||
: LT BIN: 1011 >CC ;
|
||||
: GT BIN: 1100 >CC ;
|
||||
: LE BIN: 1101 >CC ;
|
||||
: AL BIN: 1110 >CC ;
|
||||
: NV BIN: 1111 >CC ;
|
||||
: EQ ( -- ) BIN: 0000 >CC ;
|
||||
: NE ( -- ) BIN: 0001 >CC ;
|
||||
: CS ( -- ) BIN: 0010 >CC ;
|
||||
: CC ( -- ) BIN: 0011 >CC ;
|
||||
: LO ( -- ) BIN: 0100 >CC ;
|
||||
: PL ( -- ) BIN: 0101 >CC ;
|
||||
: VS ( -- ) BIN: 0110 >CC ;
|
||||
: VC ( -- ) BIN: 0111 >CC ;
|
||||
: HI ( -- ) BIN: 1000 >CC ;
|
||||
: LS ( -- ) BIN: 1001 >CC ;
|
||||
: GE ( -- ) BIN: 1010 >CC ;
|
||||
: LT ( -- ) BIN: 1011 >CC ;
|
||||
: GT ( -- ) BIN: 1100 >CC ;
|
||||
: LE ( -- ) BIN: 1101 >CC ;
|
||||
: AL ( -- ) BIN: 1110 >CC ;
|
||||
: NV ( -- ) BIN: 1111 >CC ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (insn) ( n -- ) CC> 28 shift bitor , ;
|
||||
|
||||
: insn ( bitspec -- ) bitfield (insn) ; inline
|
||||
|
||||
! Branching instructions
|
||||
GENERIC# (B) 1 ( signed-imm-24 l -- )
|
||||
GENERIC# (B) 1 ( target l -- )
|
||||
|
||||
M: integer (B) { 24 { 1 25 } { 0 26 } { 1 27 } 0 } insn ;
|
||||
M: word (B) 0 swap (B) rc-relative-arm-3 rel-word ;
|
||||
M: label (B) 0 swap (B) rc-relative-arm-3 label-fixup ;
|
||||
|
||||
: B 0 (B) ; : BL 1 (B) ;
|
||||
PRIVATE>
|
||||
|
||||
: B ( target -- ) 0 (B) ;
|
||||
: BL ( target -- ) 1 (B) ;
|
||||
|
||||
! Data processing instructions
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: updates-cond-code
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: S ( -- ) updates-cond-code on ;
|
||||
|
||||
: S> ( -- ? ) updates-cond-code [ f ] change ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: sinsn ( bitspec -- )
|
||||
bitfield S> [ 20 2^ bitor ] when (insn) ; inline
|
||||
|
||||
|
|
@ -100,21 +123,25 @@ M: register shift-imm/reg ( Rs Rm shift -- n )
|
|||
{ register 0 }
|
||||
} bitfield ;
|
||||
|
||||
GENERIC: shifter-op ( shifter-op -- n )
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: IMM immed rotate ;
|
||||
C: <IMM> IMM
|
||||
|
||||
M: IMM shifter-op
|
||||
dup IMM-immed swap IMM-rotate
|
||||
{ { 1 25 } 8 0 } bitfield ;
|
||||
|
||||
TUPLE: shifter Rm by shift ;
|
||||
C: <shifter> shifter
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: shifter-op ( shifter-op -- n )
|
||||
|
||||
M: IMM shifter-op
|
||||
[ immed>> ] [ rotate>> ] bi { { 1 25 } 8 0 } bitfield ;
|
||||
|
||||
M: shifter shifter-op
|
||||
dup shifter-by over shifter-Rm rot shifter-shift
|
||||
shift-imm/reg ;
|
||||
[ by>> ] [ Rm>> ] [ shift>> ] tri shift-imm/reg ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <LSL> ( Rm shift-imm/Rs -- shifter-op ) BIN: 00 <shifter> ;
|
||||
: <LSR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 01 <shifter> ;
|
||||
|
|
@ -123,9 +150,10 @@ M: shifter shifter-op
|
|||
: <RRX> ( Rm -- shifter-op ) 0 <ROR> ;
|
||||
|
||||
M: register shifter-op 0 <LSL> shifter-op ;
|
||||
|
||||
M: integer shifter-op 0 <IMM> shifter-op ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: addr1 ( Rd Rn shifter-op opcode -- )
|
||||
{
|
||||
21 ! opcode
|
||||
|
|
@ -134,30 +162,38 @@ M: integer shifter-op 0 <IMM> shifter-op ;
|
|||
{ register 12 } ! Rd
|
||||
} sinsn ;
|
||||
|
||||
: AND BIN: 0000 addr1 ;
|
||||
: EOR BIN: 0001 addr1 ;
|
||||
: SUB BIN: 0010 addr1 ;
|
||||
: RSB BIN: 0011 addr1 ;
|
||||
: ADD BIN: 0100 addr1 ;
|
||||
: ADC BIN: 0101 addr1 ;
|
||||
: SBC BIN: 0110 addr1 ;
|
||||
: RSC BIN: 0111 addr1 ;
|
||||
: ORR BIN: 1100 addr1 ;
|
||||
: BIC BIN: 1110 addr1 ;
|
||||
PRIVATE>
|
||||
|
||||
: MOV f swap BIN: 1101 addr1 ;
|
||||
: MVN f swap BIN: 1111 addr1 ;
|
||||
: AND ( Rd Rn shifter-op -- ) BIN: 0000 addr1 ;
|
||||
: EOR ( Rd Rn shifter-op -- ) BIN: 0001 addr1 ;
|
||||
: SUB ( Rd Rn shifter-op -- ) BIN: 0010 addr1 ;
|
||||
: RSB ( Rd Rn shifter-op -- ) BIN: 0011 addr1 ;
|
||||
: ADD ( Rd Rn shifter-op -- ) BIN: 0100 addr1 ;
|
||||
: ADC ( Rd Rn shifter-op -- ) BIN: 0101 addr1 ;
|
||||
: SBC ( Rd Rn shifter-op -- ) BIN: 0110 addr1 ;
|
||||
: RSC ( Rd Rn shifter-op -- ) BIN: 0111 addr1 ;
|
||||
: ORR ( Rd Rn shifter-op -- ) BIN: 1100 addr1 ;
|
||||
: BIC ( Rd Rn shifter-op -- ) BIN: 1110 addr1 ;
|
||||
|
||||
: MOV ( Rd shifter-op -- ) [ f ] dip BIN: 1101 addr1 ;
|
||||
: MVN ( Rd shifter-op -- ) [ f ] dip BIN: 1111 addr1 ;
|
||||
|
||||
! These always update the condition code flags
|
||||
: (CMP) >r f -rot r> S addr1 ;
|
||||
<PRIVATE
|
||||
|
||||
: TST BIN: 1000 (CMP) ;
|
||||
: TEQ BIN: 1001 (CMP) ;
|
||||
: CMP BIN: 1010 (CMP) ;
|
||||
: CMN BIN: 1011 (CMP) ;
|
||||
: (CMP) ( Rn shifter-op opcode -- ) [ f ] 3dip S addr1 ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: TST ( Rn shifter-op -- ) BIN: 1000 (CMP) ;
|
||||
: TEQ ( Rn shifter-op -- ) BIN: 1001 (CMP) ;
|
||||
: CMP ( Rn shifter-op -- ) BIN: 1010 (CMP) ;
|
||||
: CMN ( Rn shifter-op -- ) BIN: 1011 (CMP) ;
|
||||
|
||||
! Multiply instructions
|
||||
: (MLA) ( Rd Rm Rs Rn a -- )
|
||||
<PRIVATE
|
||||
|
||||
: (MLA) ( Rd Rm Rs Rn a -- )
|
||||
{
|
||||
21
|
||||
{ register 12 }
|
||||
|
|
@ -168,9 +204,6 @@ M: integer shifter-op 0 <IMM> shifter-op ;
|
|||
{ 1 4 }
|
||||
} sinsn ;
|
||||
|
||||
: MUL ( Rd Rm Rs -- ) f 0 (MLA) ;
|
||||
: MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ;
|
||||
|
||||
: (S/UMLAL) ( RdLo RdHi Rm Rs s a -- )
|
||||
{
|
||||
{ 1 23 }
|
||||
|
|
@ -184,8 +217,15 @@ M: integer shifter-op 0 <IMM> shifter-op ;
|
|||
{ 1 4 }
|
||||
} sinsn ;
|
||||
|
||||
: SMLAL 1 1 (S/UMLAL) ; : SMULL 1 0 (S/UMLAL) ;
|
||||
: UMLAL 0 1 (S/UMLAL) ; : UMULL 0 0 (S/UMLAL) ;
|
||||
PRIVATE>
|
||||
|
||||
: MUL ( Rd Rm Rs -- ) f 0 (MLA) ;
|
||||
: MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ;
|
||||
|
||||
: SMLAL ( RdLo RdHi Rm Rs -- ) 1 1 (S/UMLAL) ;
|
||||
: SMULL ( RdLo RdHi Rm Rs -- ) 1 0 (S/UMLAL) ;
|
||||
: UMLAL ( RdLo RdHi Rm Rs -- ) 0 1 (S/UMLAL) ;
|
||||
: UMULL ( RdLo RdHi Rm Rs -- ) 0 0 (S/UMLAL) ;
|
||||
|
||||
! Miscellaneous arithmetic instructions
|
||||
: CLZ ( Rd Rm -- )
|
||||
|
|
@ -203,39 +243,21 @@ M: integer shifter-op 0 <IMM> shifter-op ;
|
|||
! Status register acess instructions
|
||||
|
||||
! Load and store instructions
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: addressing-mode-2 ( addressing-mode -- n )
|
||||
|
||||
TUPLE: addressing p u w ;
|
||||
: <addressing> ( delegate p u w -- addressing )
|
||||
{
|
||||
set-delegate
|
||||
set-addressing-p
|
||||
set-addressing-u
|
||||
set-addressing-w
|
||||
} addressing construct ;
|
||||
TUPLE: addressing base p u w ;
|
||||
C: <addressing> addressing
|
||||
|
||||
M: addressing addressing-mode-2
|
||||
{
|
||||
addressing-p addressing-u addressing-w delegate
|
||||
} get-slots addressing-mode-2
|
||||
{ [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-2 ] } cleave
|
||||
{ 0 21 23 24 } bitfield ;
|
||||
|
||||
M: integer addressing-mode-2 ;
|
||||
|
||||
M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
|
||||
|
||||
! Offset
|
||||
: <+> 1 1 0 <addressing> ;
|
||||
: <-> 1 0 0 <addressing> ;
|
||||
|
||||
! Pre-indexed
|
||||
: <!+> 1 1 1 <addressing> ;
|
||||
: <!-> 1 0 1 <addressing> ;
|
||||
|
||||
! Post-indexed
|
||||
: <+!> 0 1 0 <addressing> ;
|
||||
: <-!> 0 0 0 <addressing> ;
|
||||
|
||||
: addr2 ( Rd Rn addressing-mode b l -- )
|
||||
{
|
||||
{ 1 26 }
|
||||
|
|
@ -246,16 +268,32 @@ M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
|
|||
{ register 12 }
|
||||
} insn ;
|
||||
|
||||
: LDR 0 1 addr2 ;
|
||||
: LDRB 1 1 addr2 ;
|
||||
: STR 0 0 addr2 ;
|
||||
: STRB 1 0 addr2 ;
|
||||
PRIVATE>
|
||||
|
||||
! Offset
|
||||
: <+> ( base -- addressing ) 1 1 0 <addressing> ;
|
||||
: <-> ( base -- addressing ) 1 0 0 <addressing> ;
|
||||
|
||||
! Pre-indexed
|
||||
: <!+> ( base -- addressing ) 1 1 1 <addressing> ;
|
||||
: <!-> ( base -- addressing ) 1 0 1 <addressing> ;
|
||||
|
||||
! Post-indexed
|
||||
: <+!> ( base -- addressing ) 0 1 0 <addressing> ;
|
||||
: <-!> ( base -- addressing ) 0 0 0 <addressing> ;
|
||||
|
||||
: LDR ( Rd Rn addressing-mode -- ) 0 1 addr2 ;
|
||||
: LDRB ( Rd Rn addressing-mode -- ) 1 1 addr2 ;
|
||||
: STR ( Rd Rn addressing-mode -- ) 0 0 addr2 ;
|
||||
: STRB ( Rd Rn addressing-mode -- ) 1 0 addr2 ;
|
||||
|
||||
! We might have to simulate these instructions since older ARM
|
||||
! chips don't have them.
|
||||
SYMBOL: have-BX?
|
||||
SYMBOL: have-BLX?
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC# (BX) 1 ( Rm l -- )
|
||||
|
||||
M: register (BX) ( Rm l -- )
|
||||
|
|
@ -270,24 +308,21 @@ M: register (BX) ( Rm l -- )
|
|||
{ register 0 }
|
||||
} insn ;
|
||||
|
||||
M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ;
|
||||
PRIVATE>
|
||||
|
||||
M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ;
|
||||
: BX ( Rm -- ) have-BX? get [ 0 (BX) ] [ [ PC ] dip MOV ] if ;
|
||||
|
||||
: BX have-BX? get [ 0 (BX) ] [ PC swap MOV ] if ;
|
||||
|
||||
: BLX have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ;
|
||||
: BLX ( Rm -- ) have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ;
|
||||
|
||||
! More load and store instructions
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: addressing-mode-3 ( addressing-mode -- n )
|
||||
|
||||
: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ;
|
||||
: b>n/n ( b -- n n ) [ -4 shift ] [ HEX: f bitand ] bi ;
|
||||
|
||||
M: addressing addressing-mode-3
|
||||
[ addressing-p ] keep
|
||||
[ addressing-u ] keep
|
||||
[ addressing-w ] keep
|
||||
delegate addressing-mode-3
|
||||
{ [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-3 ] } cleave
|
||||
{ 0 21 23 24 } bitfield ;
|
||||
|
||||
M: integer addressing-mode-3
|
||||
|
|
@ -318,10 +353,12 @@ M: object addressing-mode-3
|
|||
{ register 12 }
|
||||
} insn ;
|
||||
|
||||
: LDRH 1 1 0 addr3 ;
|
||||
: LDRSB 0 1 1 addr3 ;
|
||||
: LDRSH 1 1 1 addr3 ;
|
||||
: STRH 1 0 0 addr3 ;
|
||||
PRIVATE>
|
||||
|
||||
: LDRH ( Rn Rd addressing-mode -- ) 1 1 0 addr3 ;
|
||||
: LDRSB ( Rn Rd addressing-mode -- ) 0 1 1 addr3 ;
|
||||
: LDRSH ( Rn Rd addressing-mode -- ) 1 1 1 addr3 ;
|
||||
: STRH ( Rn Rd addressing-mode -- ) 1 0 0 addr3 ;
|
||||
|
||||
! Load and store multiple instructions
|
||||
|
||||
Loading…
Reference in New Issue