! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. USING: arrays compiler errors generic io kernel kernel-internals math namespaces parser sequences words ; IN: assembler ! A postfix assembler for x86 and AMD64. ! In 32-bit mode, { 1234 } is absolute indirect addressing. ! In 64-bit mode, { 1234 } is RIP-relative. ! Beware! : 4, 4 >le % ; inline : cell, cell >le % ; inline #! Extended AMD64 registers (R8-R15) return true. GENERIC: extended? ( op -- ? ) M: object extended? drop f ; ( Register operands -- eg, ECX ) : define-register ( symbol num size -- ) >r dupd "register" set-word-prop r> "register-size" set-word-prop ; ! x86 registers SYMBOL: AX \ AX 0 16 define-register SYMBOL: CX \ CX 1 16 define-register SYMBOL: DX \ DX 2 16 define-register SYMBOL: BX \ BX 3 16 define-register SYMBOL: SP \ SP 4 16 define-register SYMBOL: BP \ BP 5 16 define-register SYMBOL: SI \ SI 6 16 define-register SYMBOL: DI \ DI 7 16 define-register SYMBOL: EAX \ EAX 0 32 define-register SYMBOL: ECX \ ECX 1 32 define-register SYMBOL: EDX \ EDX 2 32 define-register SYMBOL: EBX \ EBX 3 32 define-register SYMBOL: ESP \ ESP 4 32 define-register SYMBOL: EBP \ EBP 5 32 define-register SYMBOL: ESI \ ESI 6 32 define-register SYMBOL: EDI \ EDI 7 32 define-register SYMBOL: XMM0 \ XMM0 0 128 define-register SYMBOL: XMM1 \ XMM1 1 128 define-register SYMBOL: XMM2 \ XMM2 2 128 define-register SYMBOL: XMM3 \ XMM3 3 128 define-register SYMBOL: XMM4 \ XMM4 4 128 define-register SYMBOL: XMM5 \ XMM5 5 128 define-register SYMBOL: XMM6 \ XMM6 6 128 define-register SYMBOL: XMM7 \ XMM7 7 128 define-register ! AMD64 registers SYMBOL: RAX \ RAX 0 64 define-register SYMBOL: RCX \ RCX 1 64 define-register SYMBOL: RDX \ RDX 2 64 define-register SYMBOL: RBX \ RBX 3 64 define-register SYMBOL: RSP \ RSP 4 64 define-register SYMBOL: RBP \ RBP 5 64 define-register SYMBOL: RSI \ RSI 6 64 define-register SYMBOL: RDI \ RDI 7 64 define-register SYMBOL: R8 \ R8 8 64 define-register SYMBOL: R9 \ R9 9 64 define-register SYMBOL: R10 \ R10 10 64 define-register SYMBOL: R11 \ R11 11 64 define-register SYMBOL: R12 \ R12 12 64 define-register SYMBOL: R13 \ R13 13 64 define-register SYMBOL: R14 \ R14 14 64 define-register SYMBOL: R15 \ R15 15 64 define-register SYMBOL: XMM8 \ XMM8 8 128 define-register SYMBOL: XMM9 \ XMM9 9 128 define-register SYMBOL: XMM10 \ XMM10 10 128 define-register SYMBOL: XMM11 \ XMM11 11 128 define-register SYMBOL: XMM12 \ XMM12 12 128 define-register SYMBOL: XMM13 \ XMM13 13 128 define-register SYMBOL: XMM14 \ XMM14 14 128 define-register SYMBOL: XMM15 \ XMM15 15 128 define-register PREDICATE: word register "register" word-prop ; PREDICATE: register register-16 "register-size" word-prop 16 = ; PREDICATE: register register-32 "register-size" word-prop 32 = ; PREDICATE: register register-64 "register-size" word-prop 64 = ; PREDICATE: register register-128 "register-size" word-prop 128 = ; M: register extended? "register" word-prop 7 > ; ( Addressing modes ) TUPLE: indirect base index scale displacement ; M: indirect extended? indirect-base extended? ; : canonicalize-EBP #! { EBP } ==> { EBP 0 } dup indirect-base { EBP RBP R13 } memq? [ dup indirect-displacement [ drop ] [ 0 swap set-indirect-displacement ] if ] [ drop ] if ; : canonicalize-ESP #! { ESP } ==> { ESP ESP } dup indirect-base { ESP RSP R12 } memq? [ dup indirect-base swap set-indirect-index ] [ drop ] if ; : canonicalize ( indirect -- ) #! Modify the indirect to work around certain addressing mode #! quirks. dup canonicalize-EBP canonicalize-ESP ; C: indirect ( base index scale displacement -- indirect ) [ set-indirect-displacement ] keep [ set-indirect-scale ] keep [ set-indirect-index ] keep [ set-indirect-base ] keep dup canonicalize ; : [] ( reg/displacement -- indirect ) dup integer? [ >r f f f r> ] [ f f f ] if ; : [+] ( reg displacement -- indirect ) dup integer? [ >r f f r> ] [ f f ] if ; : reg-code "register" word-prop 7 bitand ; : indirect-base* indirect-base [ EBP ] unless* reg-code ; : indirect-index* indirect-index [ ESP ] unless* reg-code ; : indirect-scale* indirect-scale [ 0 ] unless* ; GENERIC: sib-present? M: indirect sib-present? dup indirect-base { ESP RSP } memq? over indirect-index rot indirect-scale or or ; M: register sib-present? drop f ; GENERIC: r/m M: indirect r/m dup sib-present? [ drop ESP reg-code ] [ indirect-base* ] if ; M: register r/m reg-code ; : byte? -128 127 between? ; GENERIC: modifier M: indirect modifier dup indirect-base [ indirect-displacement BIN: 10 BIN: 00 ? ] [ drop BIN: 00 ] if ; M: register modifier drop BIN: 11 ; : mod-r/m ( reg# indirect -- byte ) dup modifier 6 shift rot 3 shift rot r/m bitor bitor ; : sib ( indirect -- byte ) dup sib-present? [ dup indirect-base* over indirect-index* 3 shift bitor swap indirect-scale* 6 shift bitor ] [ drop f ] if ; GENERIC: displacement M: indirect displacement indirect-displacement ; M: register displacement drop f ; : addressing ( reg# indirect -- ) [ mod-r/m , ] keep [ sib [ , ] when* ] keep displacement [ 4, ] when* ; ( Utilities ) UNION: operand register indirect ; : operand-64? ( operand -- ? ) dup indirect? [ dup indirect-base register-64? swap indirect-index register-64? or ] [ register-64? ] if ; : rex.w? ( rex.w reg mod-r/m -- ? ) [ operand-64? ] [ operand-64? ] ?if and ; : lhs-prefix extended? [ BIN: 00000100 bitor ] when ; : rhs-prefix [ extended? [ BIN: 00000001 bitor ] when ] keep dup indirect? [ indirect-index extended? [ BIN: 00000010 bitor ] when ] [ drop ] if ; : rex-prefix ( reg r/m rex.w -- ) #! Compile an AMD64 REX prefix. pick pick rex.w? BIN: 01001000 BIN: 01000000 ? swap lhs-prefix swap rhs-prefix dup BIN: 01000000 = [ drop ] [ , ] if ; : 16-prefix ( reg r/m -- ) [ register-16? ] 2apply or [ HEX: 66 , ] when ; : prefix ( reg r/m rex.w -- ) pick pick 16-prefix rex-prefix ; : prefix-1 ( reg rex.w -- ) f swap prefix ; : short-operand ( reg rex.w n -- ) #! Some instructions encode their single operand as part of #! the opcode. >r dupd prefix-1 reg-code r> + , ; : 1-operand ( op reg rex.w opcode -- ) #! The 'reg' is not really a register, but a value for the #! 'reg' field of the mod-r/m byte. >r >r over r> prefix-1 r> , swap addressing ; : immediate-1 ( imm dst reg rex.w opcode -- ) 1-operand , ; : immediate-1/4 ( imm dst reg rex.w opcode -- ) #! If imm is a byte, compile the opcode and the byte. #! Otherwise, set the 32-bit operand flag in the opcode, and #! compile the cell. The 'reg' is not really a register, but #! a value for the 'reg' field of the mod-r/m byte. >r >r pick byte? [ r> r> BIN: 10 bitor immediate-1 ] [ r> r> 1-operand 4, ] if ; : 2-operand ( dst src op -- ) #! Sets the opcode's direction bit. It is set if the #! destination is a direct register operand. pick register? [ BIN: 10 bitor swapd ] when >r 2dup t prefix r> , reg-code swap addressing ; PREDICATE: word callable register? not ; ( Moving stuff ) GENERIC: PUSH ( op -- ) M: register PUSH f HEX: 50 short-operand ; M: integer PUSH HEX: 68 , 4, ; M: callable PUSH 0 PUSH rel-absolute rel-word ; M: label PUSH 0 PUSH rel-absolute rel-label ; M: operand PUSH BIN: 110 f HEX: ff 1-operand ; GENERIC: POP ( op -- ) M: register POP f HEX: 58 short-operand ; M: operand POP BIN: 000 f HEX: 8f 1-operand ; ! MOV where the src is immediate. GENERIC: (MOV-I) ( src dst -- ) M: register (MOV-I) t HEX: b8 short-operand cell, ; M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ; GENERIC: MOV ( dst src -- ) M: integer MOV swap (MOV-I) ; M: callable MOV 0 rot (MOV-I) rel-absolute-cell rel-word ; M: label MOV 0 rot (MOV-I) rel-absolute-cell rel-label ; M: operand MOV HEX: 89 2-operand ; ( Control flow ) GENERIC: JMP ( op -- ) : (JMP) HEX: e9 , 0 4, rel-relative ; M: callable JMP (JMP) rel-word ; M: label JMP (JMP) rel-label ; M: operand JMP BIN: 100 t HEX: ff 1-operand ; GENERIC: CALL ( op -- ) : (CALL) HEX: e8 , 0 4, rel-relative ; M: callable CALL (CALL) rel-word ; M: label CALL (CALL) rel-label ; M: operand CALL BIN: 010 t HEX: ff 1-operand ; G: JUMPcc ( addr opcode -- ) 1 standard-combination ; : (JUMPcc) HEX: 0f , , 0 4, rel-relative ; M: callable JUMPcc (JUMPcc) rel-word ; M: label JUMPcc (JUMPcc) rel-label ; : JO HEX: 80 JUMPcc ; : JNO HEX: 81 JUMPcc ; : JB HEX: 82 JUMPcc ; : JAE HEX: 83 JUMPcc ; : JE HEX: 84 JUMPcc ; ! aka JZ : JNE HEX: 85 JUMPcc ; : JBE HEX: 86 JUMPcc ; : JA HEX: 87 JUMPcc ; : JS HEX: 88 JUMPcc ; : JNS HEX: 89 JUMPcc ; : JP HEX: 8a JUMPcc ; : JNP HEX: 8b JUMPcc ; : JL HEX: 8c JUMPcc ; : JGE HEX: 8d JUMPcc ; : JLE HEX: 8e JUMPcc ; : JG HEX: 8f JUMPcc ; : RET ( -- ) HEX: c3 , ; ( Arithmetic ) GENERIC: ADD ( dst src -- ) M: integer ADD swap BIN: 000 t HEX: 81 immediate-1/4 ; M: operand ADD OCT: 001 2-operand ; GENERIC: OR ( dst src -- ) M: integer OR swap BIN: 001 t HEX: 81 immediate-1/4 ; M: operand OR OCT: 011 2-operand ; GENERIC: ADC ( dst src -- ) M: integer ADC swap BIN: 010 t HEX: 81 immediate-1/4 ; M: operand ADC OCT: 021 2-operand ; GENERIC: SBB ( dst src -- ) M: integer SBB swap BIN: 011 t HEX: 81 immediate-1/4 ; M: operand SBB OCT: 031 2-operand ; GENERIC: AND ( dst src -- ) M: integer AND swap BIN: 100 t HEX: 81 immediate-1/4 ; M: operand AND OCT: 041 2-operand ; GENERIC: SUB ( dst src -- ) M: integer SUB swap BIN: 101 t HEX: 81 immediate-1/4 ; M: operand SUB OCT: 051 2-operand ; GENERIC: XOR ( dst src -- ) M: integer XOR swap BIN: 110 t HEX: 81 immediate-1/4 ; M: operand XOR OCT: 061 2-operand ; GENERIC: CMP ( dst src -- ) M: integer CMP swap BIN: 111 t HEX: 81 immediate-1/4 ; M: operand CMP OCT: 071 2-operand ; : NOT ( dst -- ) BIN: 010 t HEX: f7 1-operand ; : NEG ( dst -- ) BIN: 011 t HEX: f7 1-operand ; : MUL ( dst -- ) BIN: 100 t HEX: f7 1-operand ; : IMUL ( src -- ) BIN: 101 t HEX: f7 1-operand ; : DIV ( dst -- ) BIN: 110 t HEX: f7 1-operand ; : IDIV ( src -- ) BIN: 111 t HEX: f7 1-operand ; GENERIC: IMUL2 ( dst src -- ) M: integer IMUL2 swap dup reg-code t HEX: 69 immediate-1/4 ; : CDQ HEX: 99 , ; : CQO HEX: 48 , CDQ ; : ROL ( dst n -- ) swap BIN: 000 t HEX: c1 immediate-1 ; : ROR ( dst n -- ) swap BIN: 001 t HEX: c1 immediate-1 ; : RCL ( dst n -- ) swap BIN: 010 t HEX: c1 immediate-1 ; : RCR ( dst n -- ) swap BIN: 011 t HEX: c1 immediate-1 ; : SHL ( dst n -- ) swap BIN: 100 t HEX: c1 immediate-1 ; : SHR ( dst n -- ) swap BIN: 101 t HEX: c1 immediate-1 ; : SAR ( dst n -- ) swap BIN: 111 t HEX: c1 immediate-1 ; ( x87 Floating Point Unit ) : FSTPS ( operand -- ) BIN: 011 f HEX: d9 1-operand ; : FSTPL ( operand -- ) BIN: 011 f HEX: dd 1-operand ; : FLDS ( operand -- ) BIN: 000 f HEX: d9 1-operand ; : FLDL ( operand -- ) BIN: 000 f HEX: dd 1-operand ; ( SSE multimedia instructions ) : 2-operand-sse ( dst src op1 op2 -- ) #! We swap the operands here to make everything consistent #! with the integer instructions. swap , pick register-128? [ swapd ] [ 1 bitor ] if >r 2dup t prefix HEX: 0f , r> , reg-code swap addressing ; : MOVSS ( dest src -- ) HEX: f3 HEX: 10 2-operand-sse ; : MOVSD ( dest src -- ) HEX: f2 HEX: 10 2-operand-sse ; : ADDSD ( dest src -- ) HEX: f2 HEX: 58 2-operand-sse ; : MULSD ( dest src -- ) HEX: f2 HEX: 59 2-operand-sse ; : SUBSD ( dest src -- ) HEX: f2 HEX: 5c 2-operand-sse ; : DIVSD ( dest src -- ) HEX: f2 HEX: 5e 2-operand-sse ; : SQRTSD ( dest src -- ) HEX: f2 HEX: 51 2-operand-sse ; : UCOMISD ( dest src -- ) HEX: 66 HEX: 2e 2-operand-sse ; : COMISD ( dest src -- ) HEX: 66 HEX: 2f 2-operand-sse ; : CVTSI2SD ( dest src -- ) HEX: f2 HEX: 2a 2-operand-sse ; : CVTSD2SI ( dest src -- ) HEX: f2 HEX: 2d 2-operand-sse ;