1 ! Copyright (C) 2005, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays compiler.generator.fixup io.binary kernel
4 combinators kernel.private math namespaces make sequences
5 words system layouts math.order accessors
6 cpu.x86.assembler.syntax ;
9 ! A postfix assembler for x86 and AMD64.
11 ! In 32-bit mode, { 1234 } is absolute indirect addressing.
12 ! In 64-bit mode, { 1234 } is RIP-relative.
15 ! Register operands -- eg, ECX
16 REGISTERS: 8 AL CL DL BL ;
18 REGISTERS: 16 AX CX DX BX SP BP SI DI ;
20 REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ;
23 RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
26 XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
27 XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
35 #! Extended AMD64 registers (R8-R15) return true.
36 GENERIC: extended? ( op -- ? )
38 M: object extended? drop f ;
40 PREDICATE: register < word
41 "register" word-prop ;
43 PREDICATE: register-8 < register
44 "register-size" word-prop 8 = ;
46 PREDICATE: register-16 < register
47 "register-size" word-prop 16 = ;
49 PREDICATE: register-32 < register
50 "register-size" word-prop 32 = ;
52 PREDICATE: register-64 < register
53 "register-size" word-prop 64 = ;
55 PREDICATE: register-128 < register
56 "register-size" word-prop 128 = ;
58 M: register extended? "register" word-prop 7 > ;
61 TUPLE: indirect base index scale displacement ;
63 M: indirect extended? base>> extended? ;
65 : canonicalize-EBP ( indirect -- indirect )
66 #! { EBP } ==> { EBP 0 }
67 dup base>> { EBP RBP R13 } member? [
68 dup displacement>> [ 0 >>displacement ] unless
71 : canonicalize-ESP ( indirect -- indirect )
72 #! { ESP } ==> { ESP ESP }
73 dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
75 : canonicalize ( indirect -- indirect )
76 #! Modify the indirect to work around certain addressing mode
78 canonicalize-EBP canonicalize-ESP ;
80 : <indirect> ( base index scale displacement -- indirect )
81 indirect boa canonicalize ;
83 : reg-code ( reg -- n ) "register" word-prop 7 bitand ;
85 : indirect-base* ( op -- n ) base>> EBP or reg-code ;
87 : indirect-index* ( op -- n ) index>> ESP or reg-code ;
89 : indirect-scale* ( op -- n ) scale>> 0 or ;
91 GENERIC: sib-present? ( op -- ? )
93 M: indirect sib-present?
94 [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
96 M: register sib-present? drop f ;
98 GENERIC: r/m ( operand -- n )
102 [ drop ESP reg-code ] [ indirect-base* ] if ;
104 M: register r/m reg-code ;
107 UNION: immediate byte integer ;
109 GENERIC: fits-in-byte? ( value -- ? )
111 M: byte fits-in-byte? drop t ;
113 M: integer fits-in-byte? -128 127 between? ;
115 GENERIC: modifier ( op -- n )
120 { [ dup not ] [ BIN: 00 ] }
121 { [ dup fits-in-byte? ] [ BIN: 01 ] }
122 { [ dup immediate? ] [ BIN: 10 ] }
128 M: register modifier drop BIN: 11 ;
130 GENERIC# n, 1 ( value n -- )
132 M: integer n, >le % ;
133 M: byte n, >r value>> r> n, ;
134 : 1, ( n -- ) 1 n, ; inline
135 : 4, ( n -- ) 4 n, ; inline
136 : 2, ( n -- ) 2 n, ; inline
137 : cell, ( n -- ) bootstrap-cell n, ; inline
139 : mod-r/m, ( reg# indirect -- )
140 [ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
142 : sib, ( indirect -- )
145 [ indirect-index* 3 shift ]
146 [ indirect-scale* 6 shift ] tri bitor bitor ,
151 GENERIC: displacement, ( op -- )
153 M: indirect displacement,
154 dup displacement>> dup [
156 [ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
161 M: register displacement, drop ;
163 : addressing ( reg# indirect -- )
164 [ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
167 UNION: operand register indirect ;
169 GENERIC: operand-64? ( operand -- ? )
171 M: indirect operand-64?
172 [ base>> ] [ index>> ] bi [ operand-64? ] either? ;
174 M: register-64 operand-64? drop t ;
176 M: object operand-64? drop f ;
178 : rex.w? ( rex.w reg r/m -- ? )
180 { [ dup register-128? ] [ drop operand-64? ] }
181 { [ dup not ] [ drop operand-64? ] }
185 : rex.r ( m op -- n )
186 extended? [ BIN: 00000100 bitor ] when ;
188 : rex.b ( m op -- n )
189 [ extended? [ BIN: 00000001 bitor ] when ] keep
191 index>> extended? [ BIN: 00000010 bitor ] when
196 : rex-prefix ( reg r/m rex.w -- )
197 #! Compile an AMD64 REX prefix.
198 2over rex.w? BIN: 01001000 BIN: 01000000 ?
199 swap rex.r swap rex.b
200 dup BIN: 01000000 = [ drop ] [ , ] if ;
202 : 16-prefix ( reg r/m -- )
203 [ register-16? ] either? [ HEX: 66 , ] when ;
205 : prefix ( reg r/m rex.w -- ) 2over 16-prefix rex-prefix ;
207 : prefix-1 ( reg rex.w -- ) f swap prefix ;
209 : short-operand ( reg rex.w n -- )
210 #! Some instructions encode their single operand as part of
212 >r dupd prefix-1 reg-code r> + , ;
214 : opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
216 : extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
218 : extended-opcode, ( opcode -- ) extended-opcode opcode, ;
220 : opcode-or ( opcode mask -- opcode' )
222 [ unclip-last rot bitor suffix ] [ bitor ] if ;
224 : 1-operand ( op reg,rex.w,opcode -- )
225 #! The 'reg' is not really a register, but a value for the
226 #! 'reg' field of the mod-r/m byte.
227 first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
229 : immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
230 pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
232 : immediate-1 ( imm dst reg,rex.w,opcode -- )
233 immediate-operand-size-bit 1-operand 1, ;
235 : immediate-4 ( imm dst reg,rex.w,opcode -- )
236 immediate-operand-size-bit 1-operand 4, ;
238 : immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
239 pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
241 : immediate-1/4 ( imm dst reg,rex.w,opcode -- )
242 #! If imm is a byte, compile the opcode and the byte.
243 #! Otherwise, set the 8-bit operand flag in the opcode, and
244 #! compile the cell. The 'reg' is not really a register, but
245 #! a value for the 'reg' field of the mod-r/m byte.
247 immediate-fits-in-size-bit immediate-1
252 : (2-operand) ( dst src op -- )
253 >r 2dup t rex-prefix r> opcode,
254 reg-code swap addressing ;
256 : direction-bit ( dst src op -- dst' src' op' )
257 pick register? [ BIN: 10 opcode-or swapd ] when ;
259 : operand-size-bit ( dst src op -- dst' src' op' )
260 over register-8? [ BIN: 1 opcode-or ] unless ;
262 : 2-operand ( dst src op -- )
263 #! Sets the opcode's direction bit. It is set if the
264 #! destination is a direct register operand.
272 : [] ( reg/displacement -- indirect )
273 dup integer? [ >r f f f r> ] [ f f f ] if <indirect> ;
275 : [+] ( reg displacement -- indirect )
277 [ dup zero? [ drop f ] when >r f f r> ]
282 GENERIC: PUSH ( op -- )
283 M: register PUSH f HEX: 50 short-operand ;
284 M: immediate PUSH HEX: 68 , 4, ;
285 M: operand PUSH { BIN: 110 f HEX: ff } 1-operand ;
287 GENERIC: POP ( op -- )
288 M: register POP f HEX: 58 short-operand ;
289 M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
291 ! MOV where the src is immediate.
292 GENERIC: (MOV-I) ( src dst -- )
293 M: register (MOV-I) t HEX: b8 short-operand cell, ;
295 { BIN: 000 t HEX: c6 }
296 pick byte? [ immediate-1 ] [ immediate-4 ] if ;
298 PREDICATE: callable < word register? not ;
300 GENERIC: MOV ( dst src -- )
301 M: immediate MOV swap (MOV-I) ;
302 M: callable MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
303 M: operand MOV HEX: 88 2-operand ;
305 : LEA ( dst src -- ) swap HEX: 8d 2-operand ;
308 GENERIC: JMP ( op -- )
309 : (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
310 M: callable JMP (JMP) rel-word ;
311 M: label JMP (JMP) label-fixup ;
312 M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
314 GENERIC: CALL ( op -- )
315 : (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
316 M: callable CALL (CALL) rel-word ;
317 M: label CALL (CALL) label-fixup ;
318 M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
320 GENERIC# JUMPcc 1 ( addr opcode -- )
321 : (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
322 M: callable JUMPcc (JUMPcc) rel-word ;
323 M: label JUMPcc (JUMPcc) label-fixup ;
325 : JO ( dst -- ) HEX: 80 JUMPcc ;
326 : JNO ( dst -- ) HEX: 81 JUMPcc ;
327 : JB ( dst -- ) HEX: 82 JUMPcc ;
328 : JAE ( dst -- ) HEX: 83 JUMPcc ;
329 : JE ( dst -- ) HEX: 84 JUMPcc ; ! aka JZ
330 : JNE ( dst -- ) HEX: 85 JUMPcc ;
331 : JBE ( dst -- ) HEX: 86 JUMPcc ;
332 : JA ( dst -- ) HEX: 87 JUMPcc ;
333 : JS ( dst -- ) HEX: 88 JUMPcc ;
334 : JNS ( dst -- ) HEX: 89 JUMPcc ;
335 : JP ( dst -- ) HEX: 8a JUMPcc ;
336 : JNP ( dst -- ) HEX: 8b JUMPcc ;
337 : JL ( dst -- ) HEX: 8c JUMPcc ;
338 : JGE ( dst -- ) HEX: 8d JUMPcc ;
339 : JLE ( dst -- ) HEX: 8e JUMPcc ;
340 : JG ( dst -- ) HEX: 8f JUMPcc ;
342 : LEAVE ( -- ) HEX: c9 , ;
345 dup zero? [ drop HEX: c3 , ] [ HEX: C2 , 2, ] if ;
349 GENERIC: ADD ( dst src -- )
350 M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
351 M: operand ADD OCT: 000 2-operand ;
353 GENERIC: OR ( dst src -- )
354 M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ;
355 M: operand OR OCT: 010 2-operand ;
357 GENERIC: ADC ( dst src -- )
358 M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ;
359 M: operand ADC OCT: 020 2-operand ;
361 GENERIC: SBB ( dst src -- )
362 M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ;
363 M: operand SBB OCT: 030 2-operand ;
365 GENERIC: AND ( dst src -- )
366 M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ;
367 M: operand AND OCT: 040 2-operand ;
369 GENERIC: SUB ( dst src -- )
370 M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ;
371 M: operand SUB OCT: 050 2-operand ;
373 GENERIC: XOR ( dst src -- )
374 M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ;
375 M: operand XOR OCT: 060 2-operand ;
377 GENERIC: CMP ( dst src -- )
378 M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
379 M: operand CMP OCT: 070 2-operand ;
381 : NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
382 : NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
383 : MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
384 : IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ;
385 : DIV ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
386 : IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
388 : CDQ ( -- ) HEX: 99 , ;
389 : CQO ( -- ) HEX: 48 , CDQ ;
391 : ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
392 : ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
393 : RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
394 : RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
395 : SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
396 : SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
397 : SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
399 GENERIC: IMUL2 ( dst src -- )
400 M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
401 M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
403 : MOVSX ( dst src -- )
404 dup register-32? OCT: 143 OCT: 276 extended-opcode ?
405 over register-16? [ BIN: 1 opcode-or ] when
410 : MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
412 : CMOVO ( dst src -- ) HEX: 40 MOVcc ;
413 : CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
414 : CMOVB ( dst src -- ) HEX: 42 MOVcc ;
415 : CMOVAE ( dst src -- ) HEX: 43 MOVcc ;
416 : CMOVE ( dst src -- ) HEX: 44 MOVcc ; ! aka CMOVZ
417 : CMOVNE ( dst src -- ) HEX: 45 MOVcc ;
418 : CMOVBE ( dst src -- ) HEX: 46 MOVcc ;
419 : CMOVA ( dst src -- ) HEX: 47 MOVcc ;
420 : CMOVS ( dst src -- ) HEX: 48 MOVcc ;
421 : CMOVNS ( dst src -- ) HEX: 49 MOVcc ;
422 : CMOVP ( dst src -- ) HEX: 4a MOVcc ;
423 : CMOVNP ( dst src -- ) HEX: 4b MOVcc ;
424 : CMOVL ( dst src -- ) HEX: 4c MOVcc ;
425 : CMOVGE ( dst src -- ) HEX: 4d MOVcc ;
426 : CMOVLE ( dst src -- ) HEX: 4e MOVcc ;
427 : CMOVG ( dst src -- ) HEX: 4f MOVcc ;
431 : CPUID ( -- ) HEX: a2 extended-opcode, ;
433 ! x87 Floating Point Unit
435 : FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
436 : FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ;
438 : FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
439 : FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
441 ! SSE multimedia instructions
445 : direction-bit-sse ( dst src op1 -- dst' src' op1' )
446 pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
448 : 2-operand-sse ( dst src op1 op2 -- )
449 , direction-bit-sse extended-opcode (2-operand) ;
451 : 2-operand-int/sse ( dst src op1 op2 -- )
452 , swapd extended-opcode (2-operand) ;
456 : MOVSS ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ;
457 : MOVSD ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ;
458 : ADDSD ( dest src -- ) HEX: 58 HEX: f2 2-operand-sse ;
459 : MULSD ( dest src -- ) HEX: 59 HEX: f2 2-operand-sse ;
460 : SUBSD ( dest src -- ) HEX: 5c HEX: f2 2-operand-sse ;
461 : DIVSD ( dest src -- ) HEX: 5e HEX: f2 2-operand-sse ;
462 : SQRTSD ( dest src -- ) HEX: 51 HEX: f2 2-operand-sse ;
463 : UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-sse ;
464 : COMISD ( dest src -- ) HEX: 2f HEX: 66 2-operand-sse ;
466 : CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-sse ;
467 : CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-sse ;
469 : CVTSI2SD ( dest src -- ) HEX: 2a HEX: f2 2-operand-int/sse ;
470 : CVTSD2SI ( dest src -- ) HEX: 2d HEX: f2 2-operand-int/sse ;
471 : CVTTSD2SI ( dest src -- ) HEX: 2c HEX: f2 2-operand-int/sse ;