diff --git a/core/cpu/x86/assembler/assembler-tests.factor b/core/cpu/x86/assembler/assembler-tests.factor index caa00bd618..4c0f04fcc2 100644 --- a/core/cpu/x86/assembler/assembler-tests.factor +++ b/core/cpu/x86/assembler/assembler-tests.factor @@ -36,3 +36,6 @@ IN: cpu.x86.assembler.tests [ { HEX: 0f HEX: be HEX: c3 } ] [ [ EAX BL MOVSX ] { } make ] unit-test [ { HEX: 0f HEX: bf HEX: c3 } ] [ [ EAX BX MOVSX ] { } make ] unit-test + +[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 OR ] { } make ] unit-test +[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 MOV ] { } make ] unit-test diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index cabd81dad6..bc6a12d167 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generator.fixup io.binary kernel combinators kernel.private math namespaces parser sequences -words system layouts math.order ; +words system layouts math.order accessors ; IN: cpu.x86.assembler ! A postfix assembler for x86 and AMD64. @@ -11,11 +11,6 @@ IN: cpu.x86.assembler ! In 64-bit mode, { 1234 } is RIP-relative. ! Beware! -: n, >le % ; inline -: 4, 4 n, ; inline -: 2, 2 n, ; inline -: cell, bootstrap-cell n, ; inline - ! Register operands -- eg, ECX << @@ -45,6 +40,10 @@ REGISTERS: 128 XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ; +TUPLE: byte value ; + +C: byte + ; ! Addressing modes TUPLE: indirect base index scale displacement ; -M: indirect extended? indirect-base extended? ; +M: indirect extended? 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 ; + dup base>> { EBP RBP R13 } member? [ + dup displacement>> [ 0 >>displacement ] unless + ] when drop ; : canonicalize-ESP #! { ESP } ==> { ESP ESP } - dup indirect-base { ESP RSP R12 } memq? [ - ESP swap set-indirect-index - ] [ - drop - ] if ; + dup base>> { ESP RSP R12 } member? [ ESP >>index ] when drop ; : canonicalize ( indirect -- ) #! Modify the indirect to work around certain addressing mode #! quirks. - dup canonicalize-EBP - canonicalize-ESP ; + [ canonicalize-EBP ] [ canonicalize-ESP ] bi ; : ( base index scale displacement -- indirect ) indirect boa dup canonicalize ; : reg-code "register" word-prop 7 bitand ; -: indirect-base* indirect-base EBP or reg-code ; +: indirect-base* base>> EBP or reg-code ; -: indirect-index* indirect-index ESP or reg-code ; +: indirect-index* index>> ESP or reg-code ; -: indirect-scale* indirect-scale 0 or ; +: indirect-scale* scale>> 0 or ; GENERIC: sib-present? ( op -- ? ) M: indirect sib-present? - dup indirect-base { ESP RSP } memq? - over indirect-index rot indirect-scale or or ; + [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ; M: register sib-present? drop f ; @@ -130,16 +117,23 @@ M: indirect r/m M: register r/m reg-code ; -: byte? -128 127 between? ; +! Immediate operands +UNION: immediate byte integer ; + +GENERIC: fits-in-byte? ( value -- ? ) + +M: byte fits-in-byte? drop t ; + +M: integer fits-in-byte? -128 127 between? ; GENERIC: modifier ( op -- n ) M: indirect modifier - dup indirect-base [ - indirect-displacement { - { [ dup not ] [ BIN: 00 ] } - { [ dup byte? ] [ BIN: 01 ] } - { [ dup integer? ] [ BIN: 10 ] } + dup base>> [ + displacement>> { + { [ dup not ] [ BIN: 00 ] } + { [ dup fits-in-byte? ] [ BIN: 01 ] } + { [ dup immediate? ] [ BIN: 10 ] } } cond nip ] [ drop BIN: 00 @@ -147,14 +141,23 @@ M: indirect modifier M: register modifier drop BIN: 11 ; +GENERIC# n, 1 ( value n -- ) + +M: integer n, >le % ; +M: byte n, >r value>> r> n, ; +: 1, 1 n, ; inline +: 4, 4 n, ; inline +: 2, 2 n, ; inline +: cell, bootstrap-cell n, ; inline + : mod-r/m, ( reg# indirect -- ) - dup modifier 6 shift rot 3 shift rot r/m bitor bitor , ; + [ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ; : sib, ( indirect -- ) dup sib-present? [ - dup indirect-base* - over indirect-index* 3 shift bitor - swap indirect-scale* 6 shift bitor , + [ indirect-base* ] + [ indirect-index* 3 shift ] + [ indirect-scale* 6 shift ] tri bitor bitor , ] [ drop ] if ; @@ -162,9 +165,9 @@ M: register modifier drop BIN: 11 ; GENERIC: displacement, ( op -- ) M: indirect displacement, - dup indirect-displacement dup [ - swap indirect-base - [ dup byte? [ , ] [ 4, ] if ] [ 4, ] if + dup displacement>> dup [ + swap base>> + [ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if ] [ 2drop ] if ; @@ -172,18 +175,19 @@ M: indirect displacement, M: register displacement, drop ; : addressing ( reg# indirect -- ) - [ mod-r/m, ] keep [ sib, ] keep displacement, ; + [ mod-r/m, ] [ sib, ] [ displacement, ] tri ; ! Utilities UNION: operand register indirect ; -: operand-64? ( operand -- ? ) - dup indirect? [ - dup indirect-base register-64? - swap indirect-index register-64? or - ] [ - register-64? - ] if ; +GENERIC: operand-64? ( operand -- ? ) + +M: indirect operand-64? + [ base>> ] [ index>> ] bi [ operand-64? ] either? ; + +M: register-64 operand-64? drop t ; + +M: object operand-64? drop f ; : rex.w? ( rex.w reg r/m -- ? ) { @@ -198,8 +202,7 @@ UNION: operand register indirect ; : rex.b [ extended? [ BIN: 00000001 bitor ] when ] keep dup indirect? [ - indirect-index extended? - [ BIN: 00000010 bitor ] when + index>> extended? [ BIN: 00000010 bitor ] when ] [ drop ] if ; @@ -230,25 +233,34 @@ UNION: operand register indirect ; : opcode-or ( opcode mask -- opcode' ) swap dup array? - [ 1 cut* first rot bitor suffix ] [ bitor ] if ; + [ unclip-last rot bitor suffix ] [ bitor ] if ; -: 1-operand ( op reg rex.w opcode -- ) +: 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> opcode, swap addressing ; + first3 >r >r over r> prefix-1 r> opcode, swap addressing ; -: immediate-1 ( imm dst reg rex.w opcode -- ) - 1-operand , ; +: immediate-operand-size-bit + pick integer? [ first3 BIN: 1 opcode-or 3array ] when ; -: immediate-1/4 ( imm dst reg rex.w opcode -- ) +: immediate-1 ( imm dst reg,rex.w,opcode -- ) + immediate-operand-size-bit 1-operand 1, ; + +: immediate-4 ( imm dst reg,rex.w,opcode -- ) + immediate-operand-size-bit 1-operand 4, ; + +: immediate-fits-in-size-bit + pick integer? [ first3 BIN: 10 opcode-or 3array ] when ; + +: 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 + #! Otherwise, set the 8-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 opcode-or immediate-1 + pick fits-in-byte? [ + immediate-fits-in-size-bit immediate-1 ] [ - r> r> 1-operand 4, + immediate-4 ] if ; : (2-operand) ( dst src op -- ) @@ -283,22 +295,24 @@ PRIVATE> ! Moving stuff GENERIC: PUSH ( op -- ) M: register PUSH f HEX: 50 short-operand ; -M: integer PUSH HEX: 68 , 4, ; -M: operand PUSH BIN: 110 f HEX: ff 1-operand ; +M: immediate PUSH HEX: 68 , 4, ; +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 ; +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, ; +M: operand (MOV-I) + { BIN: 000 t HEX: c6 } + pick byte? [ immediate-1 ] [ immediate-4 ] if ; PREDICATE: callable < word register? not ; GENERIC: MOV ( dst src -- ) -M: integer MOV swap (MOV-I) ; +M: immediate MOV swap (MOV-I) ; M: callable MOV 0 rot (MOV-I) rc-absolute-cell rel-word ; M: operand MOV HEX: 88 2-operand ; @@ -309,13 +323,13 @@ GENERIC: JMP ( op -- ) : (JMP) HEX: e9 , 0 4, rc-relative ; M: callable JMP (JMP) rel-word ; M: label JMP (JMP) label-fixup ; -M: operand JMP BIN: 100 t HEX: ff 1-operand ; +M: operand JMP { BIN: 100 t HEX: ff } 1-operand ; GENERIC: CALL ( op -- ) : (CALL) HEX: e8 , 0 4, rc-relative ; M: callable CALL (CALL) rel-word ; M: label CALL (CALL) label-fixup ; -M: operand CALL BIN: 010 t HEX: ff 1-operand ; +M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; GENERIC# JUMPcc 1 ( addr opcode -- ) : (JUMPcc) extended-opcode, 0 4, rc-relative ; @@ -347,57 +361,57 @@ M: label JUMPcc (JUMPcc) label-fixup ; ! Arithmetic GENERIC: ADD ( dst src -- ) -M: integer ADD swap BIN: 000 t HEX: 81 immediate-1/4 ; +M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ; M: operand ADD OCT: 000 2-operand ; GENERIC: OR ( dst src -- ) -M: integer OR swap BIN: 001 t HEX: 81 immediate-1/4 ; +M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ; M: operand OR OCT: 010 2-operand ; GENERIC: ADC ( dst src -- ) -M: integer ADC swap BIN: 010 t HEX: 81 immediate-1/4 ; +M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ; M: operand ADC OCT: 020 2-operand ; GENERIC: SBB ( dst src -- ) -M: integer SBB swap BIN: 011 t HEX: 81 immediate-1/4 ; +M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ; M: operand SBB OCT: 030 2-operand ; GENERIC: AND ( dst src -- ) -M: integer AND swap BIN: 100 t HEX: 81 immediate-1/4 ; +M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ; M: operand AND OCT: 040 2-operand ; GENERIC: SUB ( dst src -- ) -M: integer SUB swap BIN: 101 t HEX: 81 immediate-1/4 ; +M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ; M: operand SUB OCT: 050 2-operand ; GENERIC: XOR ( dst src -- ) -M: integer XOR swap BIN: 110 t HEX: 81 immediate-1/4 ; +M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ; M: operand XOR OCT: 060 2-operand ; GENERIC: CMP ( dst src -- ) -M: integer CMP swap BIN: 111 t HEX: 81 immediate-1/4 ; +M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ; M: operand CMP OCT: 070 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 ; +: 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 ; : 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 ; +: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ; +: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ; +: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ; +: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ; +: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ; +: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ; +: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ; GENERIC: IMUL2 ( dst src -- ) -M: integer IMUL2 swap dup reg-code t HEX: 69 immediate-1/4 ; +M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ; M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ; : MOVSX ( dst src -- ) @@ -432,11 +446,11 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ; ! x87 Floating Point Unit -: FSTPS ( operand -- ) BIN: 011 f HEX: d9 1-operand ; -: FSTPL ( operand -- ) BIN: 011 f HEX: dd 1-operand ; +: 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 ; +: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ; +: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ; ! SSE multimedia instructions diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index e0004f5f61..db303982ba 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -66,12 +66,12 @@ IN: cpu.x86.intrinsics ! Mark the card "obj" operand card-bits SHR "cards_offset" f temp-reg v>operand %alien-global - temp-reg v>operand "obj" operand [+] card-mark OR + temp-reg v>operand "obj" operand [+] card-mark OR ! Mark the card deck "obj" operand deck-bits card-bits - SHR "decks_offset" f temp-reg v>operand %alien-global - temp-reg v>operand "obj" operand [+] card-mark MOV + temp-reg v>operand "obj" operand [+] card-mark MOV ] unless ; \ set-slot {