Better support for 8-bit instructions in x86 assembler, more efficient write barrier on x86

db4
Slava Pestov 2008-05-08 20:34:40 -05:00
parent 793c58f7a2
commit 89de1282be
3 changed files with 113 additions and 96 deletions

View File

@ -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 <byte> OR ] { } make ] unit-test
[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test

View File

@ -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> byte
<PRIVATE
#! Extended AMD64 registers (R8-R15) return true.
@ -75,50 +74,38 @@ M: register extended? "register" word-prop 7 > ;
! 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 ;
: <indirect> ( 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

View File

@ -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 <byte> 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 <byte> MOV
] unless ;
\ set-slot {