1 ! Copyright (C) 2007, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays combinators kernel make math math.bitwise
4 namespaces sequences words words.symbol parser ;
12 V{ } registers set-global
17 [ registers get length "register" set-word-prop ]
18 [ registers get push ]
40 ALIAS: SL R10 ALIAS: FP R11 ALIAS: IP R12
41 ALIAS: SP R13 ALIAS: LR R14 ALIAS: PC R15
45 PREDICATE: register < word register >boolean ;
47 GENERIC: register ( register -- n )
48 M: word register "register" word-prop ;
49 M: f register drop 0 ;
60 #! Default value is BIN: 1110 AL (= always)
61 cond-code [ f ] change BIN: 1110 or ;
63 : EQ ( -- ) BIN: 0000 >CC ;
64 : NE ( -- ) BIN: 0001 >CC ;
65 : CS ( -- ) BIN: 0010 >CC ;
66 : CC ( -- ) BIN: 0011 >CC ;
67 : LO ( -- ) BIN: 0100 >CC ;
68 : PL ( -- ) BIN: 0101 >CC ;
69 : VS ( -- ) BIN: 0110 >CC ;
70 : VC ( -- ) BIN: 0111 >CC ;
71 : HI ( -- ) BIN: 1000 >CC ;
72 : LS ( -- ) BIN: 1001 >CC ;
73 : GE ( -- ) BIN: 1010 >CC ;
74 : LT ( -- ) BIN: 1011 >CC ;
75 : GT ( -- ) BIN: 1100 >CC ;
76 : LE ( -- ) BIN: 1101 >CC ;
77 : AL ( -- ) BIN: 1110 >CC ;
78 : NV ( -- ) BIN: 1111 >CC ;
82 : (insn) ( n -- ) CC> 28 shift bitor , ;
84 : insn ( bitspec -- ) bitfield (insn) ; inline
86 ! Branching instructions
87 GENERIC# (B) 1 ( target l -- )
89 M: integer (B) { 24 { 1 25 } { 0 26 } { 1 27 } 0 } insn ;
93 : B ( target -- ) 0 (B) ;
94 : BL ( target -- ) 1 (B) ;
96 ! Data processing instructions
99 SYMBOL: updates-cond-code
103 : S ( -- ) updates-cond-code on ;
105 : S> ( -- ? ) updates-cond-code [ f ] change ;
109 : sinsn ( bitspec -- )
110 bitfield S> [ 20 2^ bitor ] when (insn) ; inline
112 GENERIC# shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n )
114 M: integer shift-imm/reg ( shift-imm Rm shift -- n )
115 { { 0 4 } 5 { register 0 } 7 } bitfield ;
117 M: register shift-imm/reg ( Rs Rm shift -- n )
128 TUPLE: IMM immed rotate ;
131 TUPLE: shifter Rm by shift ;
136 GENERIC: shifter-op ( shifter-op -- n )
139 [ immed>> ] [ rotate>> ] bi { { 1 25 } 8 0 } bitfield ;
141 M: shifter shifter-op
142 [ by>> ] [ Rm>> ] [ shift>> ] tri shift-imm/reg ;
146 : <LSL> ( Rm shift-imm/Rs -- shifter-op ) BIN: 00 <shifter> ;
147 : <LSR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 01 <shifter> ;
148 : <ASR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 10 <shifter> ;
149 : <ROR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 11 <shifter> ;
150 : <RRX> ( Rm -- shifter-op ) 0 <ROR> ;
152 M: register shifter-op 0 <LSL> shifter-op ;
153 M: integer shifter-op 0 <IMM> shifter-op ;
157 : addr1 ( Rd Rn shifter-op opcode -- )
167 : AND ( Rd Rn shifter-op -- ) BIN: 0000 addr1 ;
168 : EOR ( Rd Rn shifter-op -- ) BIN: 0001 addr1 ;
169 : SUB ( Rd Rn shifter-op -- ) BIN: 0010 addr1 ;
170 : RSB ( Rd Rn shifter-op -- ) BIN: 0011 addr1 ;
171 : ADD ( Rd Rn shifter-op -- ) BIN: 0100 addr1 ;
172 : ADC ( Rd Rn shifter-op -- ) BIN: 0101 addr1 ;
173 : SBC ( Rd Rn shifter-op -- ) BIN: 0110 addr1 ;
174 : RSC ( Rd Rn shifter-op -- ) BIN: 0111 addr1 ;
175 : ORR ( Rd Rn shifter-op -- ) BIN: 1100 addr1 ;
176 : BIC ( Rd Rn shifter-op -- ) BIN: 1110 addr1 ;
178 : MOV ( Rd shifter-op -- ) [ f ] dip BIN: 1101 addr1 ;
179 : MVN ( Rd shifter-op -- ) [ f ] dip BIN: 1111 addr1 ;
181 ! These always update the condition code flags
184 : (CMP) ( Rn shifter-op opcode -- ) [ f ] 3dip S addr1 ;
188 : TST ( Rn shifter-op -- ) BIN: 1000 (CMP) ;
189 : TEQ ( Rn shifter-op -- ) BIN: 1001 (CMP) ;
190 : CMP ( Rn shifter-op -- ) BIN: 1010 (CMP) ;
191 : CMN ( Rn shifter-op -- ) BIN: 1011 (CMP) ;
193 ! Multiply instructions
196 : (MLA) ( Rd Rm Rs Rn a -- )
207 : (S/UMLAL) ( RdLo RdHi Rm Rs s a -- )
222 : MUL ( Rd Rm Rs -- ) f 0 (MLA) ;
223 : MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ;
225 : SMLAL ( RdLo RdHi Rm Rs -- ) 1 1 (S/UMLAL) ;
226 : SMULL ( RdLo RdHi Rm Rs -- ) 1 0 (S/UMLAL) ;
227 : UMLAL ( RdLo RdHi Rm Rs -- ) 0 1 (S/UMLAL) ;
228 : UMULL ( RdLo RdHi Rm Rs -- ) 0 0 (S/UMLAL) ;
230 ! Miscellaneous arithmetic instructions
243 ! Status register acess instructions
245 ! Load and store instructions
248 GENERIC: addressing-mode-2 ( addressing-mode -- n )
250 TUPLE: addressing base p u w ;
251 C: <addressing> addressing
253 M: addressing addressing-mode-2
254 { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-2 ] } cleave
255 { 0 21 23 24 } bitfield ;
257 M: integer addressing-mode-2 ;
259 M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
261 : addr2 ( Rd Rn addressing-mode b l -- )
266 { addressing-mode-2 0 }
274 : <+> ( base -- addressing ) 1 1 0 <addressing> ;
275 : <-> ( base -- addressing ) 1 0 0 <addressing> ;
278 : <!+> ( base -- addressing ) 1 1 1 <addressing> ;
279 : <!-> ( base -- addressing ) 1 0 1 <addressing> ;
282 : <+!> ( base -- addressing ) 0 1 0 <addressing> ;
283 : <-!> ( base -- addressing ) 0 0 0 <addressing> ;
285 : LDR ( Rd Rn addressing-mode -- ) 0 1 addr2 ;
286 : LDRB ( Rd Rn addressing-mode -- ) 1 1 addr2 ;
287 : STR ( Rd Rn addressing-mode -- ) 0 0 addr2 ;
288 : STRB ( Rd Rn addressing-mode -- ) 1 0 addr2 ;
290 ! We might have to simulate these instructions since older ARM
291 ! chips don't have them.
297 GENERIC# (BX) 1 ( Rm l -- )
299 M: register (BX) ( Rm l -- )
313 : BX ( Rm -- ) have-BX? get [ 0 (BX) ] [ [ PC ] dip MOV ] if ;
315 : BLX ( Rm -- ) have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ;
317 ! More load and store instructions
320 GENERIC: addressing-mode-3 ( addressing-mode -- n )
322 : b>n/n ( b -- n n ) [ -4 shift ] [ HEX: f bitand ] bi ;
324 M: addressing addressing-mode-3
325 { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-3 ] } cleave
326 { 0 21 23 24 } bitfield ;
328 M: integer addressing-mode-3
338 M: object addressing-mode-3
346 : addr3 ( Rn Rd addressing-mode h l s -- )
351 { addressing-mode-3 0 }
358 : LDRH ( Rn Rd addressing-mode -- ) 1 1 0 addr3 ;
359 : LDRSB ( Rn Rd addressing-mode -- ) 0 1 1 addr3 ;
360 : LDRSH ( Rn Rd addressing-mode -- ) 1 1 1 addr3 ;
361 : STRH ( Rn Rd addressing-mode -- ) 1 0 0 addr3 ;
363 ! Load and store multiple instructions
365 ! Semaphore instructions
367 ! Exception-generating instructions