cpu.x86.assembler: small cleanups

diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor
index 83186a7f24d5ce5a5a04750346b056fbfe77845b..7312a16f833ddad764b5c53f17556bfc14379890 100644 (file)
--- a/basis/cpu/x86/assembler/assembler-tests.factor
+++ b/basis/cpu/x86/assembler/assembler-tests.factor
@@ -2,6 +2,13 @@ USING: cpu.x86.assembler cpu.x86.assembler.operands
 kernel tools.test namespaces make layouts ;
 IN: cpu.x86.assembler.tests
 
+! immediate operands
+[ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test
+[ { HEX: 83 HEX: c1 HEX: 01 } ] [ [ ECX 1 ADD ] { } make ] unit-test
+[ { HEX: 81 HEX: c1 HEX: 96 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 150 ADD ] { } make ] unit-test
+[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
+
+! 64-bit registers
 [ { HEX: 40 HEX: 8a HEX: 2a } ] [ [ BPL RDX [] MOV ] { } make ] unit-test
 
 [ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
@@ -100,13 +107,6 @@ IN: cpu.x86.assembler.tests
 [ { HEX: f2 HEX: 48 HEX: 0f HEX: 2a HEX: c0 } ] [ [ XMM0 RAX CVTSI2SD ] { } make ] unit-test
 [ { HEX: f2 HEX: 49 HEX: 0f HEX: 2a HEX: c4 } ] [ [ XMM0 R12 CVTSI2SD ] { } make ] unit-test
 
-! [ { HEX: f2 HEX: 49 HEX: 0f HEX: 2c HEX: c1 } ] [ [ XMM9 RAX CVTSI2SD ] { } make ] unit-test
-
-! [ { HEX: f2 HEX: 0f HEX: 10 HEX: 00 } ] [ [ XMM0 RAX [] MOVSD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 10 HEX: 04 HEX: 24 } ] [ [ XMM0 R12 [] MOVSD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 0f HEX: 11 HEX: 00 } ] [ [ RAX [] XMM0 MOVSD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 11 HEX: 04 HEX: 24 } ] [ [ R12 [] XMM0 MOVSD ] { } make ] unit-test
-
 ! 3-operand r-rm-imm sse instructions
 [ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ]
 [ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test
@@ -167,14 +167,18 @@ IN: cpu.x86.assembler.tests
 [ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: c1 } ] [ [ EAX ECX CRC32 ] { } make ] unit-test
 [ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: 01 } ] [ [ EAX ECX [] CRC32 ] { } make ] unit-test
 
-! various oddities
+! shifts
 [ { HEX: 48 HEX: d3 HEX: e0 } ] [ [ RAX CL SHL ] { } make ] unit-test
 [ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
 [ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
 [ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
 
-[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
+[ { HEX: c1 HEX: e0 HEX: 05 } ] [ [ EAX 5 SHL ] { } make ] unit-test
+[ { HEX: c1 HEX: e1 HEX: 05 } ] [ [ ECX 5 SHL ] { } make ] unit-test
+[ { HEX: c1 HEX: e8 HEX: 05 } ] [ [ EAX 5 SHR ] { } make ] unit-test
+[ { HEX: c1 HEX: e9 HEX: 05 } ] [ [ ECX 5 SHR ] { } make ] unit-test
 
+! multiplication
 [ { HEX: 4d HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 R8 3 IMUL3 ] { } make ] unit-test
 [ { HEX: 49 HEX: 6b HEX: c0 HEX: 03 } ] [ [ RAX R8 3 IMUL3 ] { } make ] unit-test
 [ { HEX: 4c HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 RAX 3 IMUL3 ] { } make ] unit-test

diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor
index b91083dad1f64345b727ecc2330d403c61e63a4c..059be328f2c1700449dac8e70ff9808179d828c6 100644 (file)
--- a/basis/cpu/x86/assembler/assembler.factor
+++ b/basis/cpu/x86/assembler/assembler.factor
@@ -4,7 +4,6 @@ USING: arrays io.binary kernel combinators
 combinators.short-circuit math math.bitwise locals namespaces
 make sequences words system layouts math.order accessors
 cpu.x86.assembler.operands cpu.x86.assembler.operands.private ;
-QUALIFIED: sequences
 IN: cpu.x86.assembler
 
 ! A postfix assembler for x86-32 and x86-64.
@@ -71,10 +70,10 @@ M: byte n, [ value>> ] dip n, ;
 : 2, ( n -- ) 2 n, ; inline
 : cell, ( n -- ) bootstrap-cell n, ; inline
 
-: mod-r/m, ( reg# indirect -- )
+: mod-r/m, ( reg operand -- )
     [ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
 
-: sib, ( indirect -- )
+: sib, ( operand -- )
     dup sib-present? [
         [ indirect-base* ]
         [ indirect-index* 3 shift ]
@@ -93,14 +92,14 @@ M: indirect displacement,
 
 M: register displacement, drop ;
 
-: addressing ( reg# indirect -- )
+: addressing ( reg operand -- )
     [ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
 
 : rex.w? ( rex.w reg r/m -- ? )
     {
-        { [ dup register-128? ] [ drop operand-64? ] }
-        { [ dup not ] [ drop operand-64? ] }
-        [ nip operand-64? ]
+        { [ over register-128? ] [ nip operand-64? ] }
+        { [ over not ] [ nip operand-64? ] }
+        [ drop operand-64? ]
     } cond and ;
 
 : rex.r ( m op -- n )
@@ -119,16 +118,15 @@ M: register displacement, drop ;
 :: rex-prefix ( reg r/m rex.w -- )
     #! Compile an AMD64 REX prefix.
     rex.w reg r/m rex.w? BIN: 01001000 BIN: 01000000 ?
-    r/m rex.r
-    reg rex.b
+    reg rex.r
+    r/m rex.b
     dup reg r/m no-prefix? [ drop ] [ , ] if ;
 
-: 16-prefix ( reg r/m -- )
-    [ register-16? ] either? [ HEX: 66 , ] when ;
+: 16-prefix ( reg -- )
+    register-16? [ HEX: 66 , ] when ;
 
-: prefix ( reg r/m rex.w -- ) [ drop 16-prefix ] [ rex-prefix ] 3bi ;
-
-: prefix-1 ( reg rex.w -- ) f swap prefix ;
+: prefix-1 ( reg rex.w -- )
+    [ drop 16-prefix ] [ [ f ] 2dip rex-prefix ] 2bi ;
 
 : short-operand ( reg rex.w n -- )
     #! Some instructions encode their single operand as part of
@@ -138,57 +136,57 @@ M: register displacement, drop ;
 : opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
 
 : extended-opcode ( opcode -- opcode' )
-    dup array? [ OCT: 17 sequences:prefix ] [ OCT: 17 swap 2array ] if ;
+    dup array? [ OCT: 17 prefix ] [ OCT: 17 swap 2array ] if ;
 
 : extended-opcode, ( opcode -- ) extended-opcode opcode, ;
 
 : opcode-or ( opcode mask -- opcode' )
-    swap dup array?
-    [ unclip-last rot bitor suffix ] [ bitor ] if ;
+    over array?
+    [ [ unclip-last ] dip bitor suffix ] [ bitor ] if ;
 
-: 1-operand ( op reg,rex.w,opcode -- )
+: 1-operand ( operand reg,rex.w,opcode -- )
     #! The 'reg' is not really a register, but a value for the
     #! 'reg' field of the mod-r/m byte.
     first3 [ [ over ] dip prefix-1 ] dip opcode, swap addressing ;
 
-: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
-    pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
+: immediate-operand-size-bit ( dst imm reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
+    over integer? [ first3 BIN: 1 opcode-or 3array ] when ;
 
-: immediate-1 ( imm dst reg,rex.w,opcode -- )
-    immediate-operand-size-bit 1-operand 1, ;
+: immediate-1 ( dst imm reg,rex.w,opcode -- )
+    immediate-operand-size-bit swap [ 1-operand ] dip 1, ;
 
-: immediate-4 ( imm dst reg,rex.w,opcode -- )
-    immediate-operand-size-bit 1-operand 4, ;
+: immediate-4 ( dst imm reg,rex.w,opcode -- )
+    immediate-operand-size-bit swap [ 1-operand ] dip 4, ;
 
-: immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
-    pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
+: immediate-fits-in-size-bit ( dst imm reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
+    over integer? [ first3 BIN: 10 opcode-or 3array ] when ;
 
-: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
+: immediate-1/4 ( dst imm reg,rex.w,opcode -- )
     #! If imm is a byte, compile the opcode and the byte.
     #! 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.
-    pick fits-in-byte? [
+    over fits-in-byte? [
         immediate-fits-in-size-bit immediate-1
     ] [
         immediate-4
     ] if ;
 
-: (2-operand) ( dst src op -- )
+: (2-operand) ( reg operand op -- )
     [ 2dup t rex-prefix ] dip opcode,
-    reg-code swap addressing ;
+    [ reg-code ] dip addressing ;
 
-: direction-bit ( dst src op -- dst' src' op' )
+: direction-bit ( dst src op -- reg operand op' )
     pick register? pick register? not and
-    [ BIN: 10 opcode-or swapd ] when ;
+    [ BIN: 10 opcode-or ] [ swapd ] if ;
 
-: operand-size-bit ( dst src op -- dst' src' op' )
-    over register-8? [ BIN: 1 opcode-or ] unless ;
+: operand-size-bit ( reg operand op -- reg operand op' )
+    pick register-8? [ BIN: 1 opcode-or ] unless ;
 
 : 2-operand ( dst src op -- )
-    #! Sets the opcode's direction bit. It is set if the
-    #! destination is a direct register operand.
-    [ drop 16-prefix ] [ direction-bit operand-size-bit (2-operand) ] 3bi ;
+    direction-bit operand-size-bit
+    pick 16-prefix
+    (2-operand) ;
 
 PRIVATE>
 
@@ -212,16 +210,16 @@ M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
 ! MOV where the src is immediate.
 <PRIVATE
 
-GENERIC: (MOV-I) ( src dst -- )
-M: register (MOV-I) t HEX: b8 short-operand cell, ;
+GENERIC# (MOV-I) 1 ( dst src -- )
+M: register (MOV-I) [ t HEX: b8 short-operand ] [ cell, ] bi* ;
 M: operand (MOV-I)
     { BIN: 000 t HEX: c6 }
-    pick byte? [ immediate-1 ] [ immediate-4 ] if ;
+    over byte? [ immediate-1 ] [ immediate-4 ] if ;
 
 PRIVATE>
 
 GENERIC: MOV ( dst src -- )
-M: immediate MOV swap (MOV-I) ;
+M: immediate MOV (MOV-I) ;
 M: operand MOV HEX: 88 2-operand ;
 
 : LEA ( dst src -- ) swap HEX: 8d 2-operand ;
@@ -267,44 +265,44 @@ PRIVATE>
 ! Arithmetic
 
 GENERIC: ADD ( dst src -- )
-M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
+M: immediate ADD { BIN: 000 t HEX: 80 } immediate-1/4 ;
 M: operand ADD OCT: 000 2-operand ;
 
 GENERIC: OR ( dst src -- )
-M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ;
+M: immediate OR { BIN: 001 t HEX: 80 } immediate-1/4 ;
 M: operand OR OCT: 010 2-operand ;
 
 GENERIC: ADC ( dst src -- )
-M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ;
+M: immediate ADC { BIN: 010 t HEX: 80 } immediate-1/4 ;
 M: operand ADC OCT: 020 2-operand ;
 
 GENERIC: SBB ( dst src -- )
-M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ;
+M: immediate SBB { BIN: 011 t HEX: 80 } immediate-1/4 ;
 M: operand SBB OCT: 030 2-operand ;
 
 GENERIC: AND ( dst src -- )
-M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ;
+M: immediate AND { BIN: 100 t HEX: 80 } immediate-1/4 ;
 M: operand AND OCT: 040 2-operand ;
 
 GENERIC: SUB ( dst src -- )
-M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ;
+M: immediate SUB { BIN: 101 t HEX: 80 } immediate-1/4 ;
 M: operand SUB OCT: 050 2-operand ;
 
 GENERIC: XOR ( dst src -- )
-M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ;
+M: immediate XOR { BIN: 110 t HEX: 80 } immediate-1/4 ;
 M: operand XOR OCT: 060 2-operand ;
 
 GENERIC: CMP ( dst src -- )
-M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
+M: immediate CMP { BIN: 111 t HEX: 80 } immediate-1/4 ;
 M: operand CMP OCT: 070 2-operand ;
 
 GENERIC: TEST ( dst src -- )
-M: immediate TEST swap { BIN: 0 t HEX: f7 } immediate-4 ;
+M: immediate TEST { BIN: 0 t HEX: f7 } immediate-4 ;
 M: operand TEST OCT: 204 2-operand ;
 
 : XCHG ( dst src -- ) OCT: 207 2-operand ;
 
-: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
+: BSR ( dst src -- ) { HEX: 0f HEX: bd } (2-operand) ;
 
 : NOT  ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
 : NEG  ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
@@ -318,11 +316,11 @@ M: operand TEST OCT: 204 2-operand ;
 
 <PRIVATE
 
-: (SHIFT) ( dst src op -- )
-    over CL eq? [
-        nip t HEX: d3 3array 1-operand
+:: (SHIFT) ( dst src op -- )
+    src CL eq? [
+        dst { op t HEX: d3 } 1-operand
     ] [
-        swapd t HEX: c0 3array immediate-1
+        dst src { op t HEX: c0 } immediate-1
     ] if ; inline
 
 PRIVATE>
@@ -336,7 +334,7 @@ PRIVATE>
 : SAR ( dst n -- ) BIN: 111 (SHIFT) ;
 
 : IMUL2 ( dst src -- )
-    OCT: 257 extended-opcode (2-operand) ;
+    swap OCT: 257 extended-opcode (2-operand) ;
 
 : IMUL3 ( dst src imm -- )
     dup fits-in-byte? [
@@ -346,19 +344,17 @@ PRIVATE>
     ] if ;
 
 : MOVSX ( dst src -- )
-    swap
-    over register-32? OCT: 143 OCT: 276 extended-opcode ?
-    pick register-16? [ BIN: 1 opcode-or ] when
+    dup register-32? OCT: 143 OCT: 276 extended-opcode ?
+    over register-16? [ BIN: 1 opcode-or ] when
     (2-operand) ;
 
 : MOVZX ( dst src -- )
-    swap
     OCT: 266 extended-opcode
-    pick register-16? [ BIN: 1 opcode-or ] when
+    over register-16? [ BIN: 1 opcode-or ] when
     (2-operand) ;
 
 ! Conditional move
-: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
+: MOVcc ( dst src cc -- ) extended-opcode (2-operand) ;
 
 : CMOVO  ( dst src -- ) HEX: 40 MOVcc ;
 : CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
@@ -409,34 +405,34 @@ PRIVATE>
 <PRIVATE
 
 : direction-bit-sse ( dst src op1 -- dst' src' op1' )
-    pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
+    pick register-128? [ swapd BIN: 1 bitor ] unless ;
 
 : 2-operand-sse ( dst src op1 op2 -- )
     [ , ] when* direction-bit-sse extended-opcode (2-operand) ;
 
 : direction-op-sse ( dst src op1s -- dst' src' op1' )
-    pick register-128? [ swapd first ] [ second ] if ;
+    pick register-128? [ first ] [ swapd second ] if ;
 
 : 2-operand-rm-mr-sse ( dst src op1{rm,mr} op2 -- )
     [ , ] when* direction-op-sse extended-opcode (2-operand) ;
 
 : 2-operand-rm-sse ( dst src op1 op2 -- )
-    [ , ] when* swapd extended-opcode (2-operand) ;
+    [ , ] when* extended-opcode (2-operand) ;
 
 : 2-operand-mr-sse ( dst src op1 op2 -- )
-    [ , ] when* extended-opcode (2-operand) ;
+    [ , ] when* extended-opcode swapd (2-operand) ;
 
 : 2-operand-int/sse ( dst src op1 op2 -- )
-    [ , ] when* swapd extended-opcode (2-operand) ;
+    [ , ] when* extended-opcode (2-operand) ;
 
-: 3-operand-rm-sse ( dst src imm op1 op2 -- )
-    rot [ 2-operand-rm-sse ] dip , ;
+:: 3-operand-rm-sse ( dst src imm op1 op2 -- )
+    dst src op1 op2 2-operand-rm-sse imm , ;
 
-: 3-operand-mr-sse ( dst src imm op1 op2 -- )
-    rot [ 2-operand-mr-sse ] dip , ;
+:: 3-operand-mr-sse ( dst src imm op1 op2 -- )
+    dst src op1 op2 2-operand-mr-sse imm , ;
 
-: 3-operand-rm-mr-sse ( dst src imm op1 op2 -- )
-    rot [ 2-operand-rm-mr-sse ] dip , ;
+:: 3-operand-rm-mr-sse ( dst src imm op1 op2 -- )
+    dst src op1 op2 2-operand-rm-mr-sse imm , ;
 
 : 2-operand-sse-cmp ( dst src cmp op1 op2 -- )
     3-operand-rm-sse ; inline
@@ -739,7 +735,7 @@ PRIVATE>
 : CMPNLESS   ( dest src -- ) 6 HEX: c2 HEX: f3 2-operand-sse-cmp ;
 : CMPORDSS   ( dest src -- ) 7 HEX: c2 HEX: f3 2-operand-sse-cmp ;
 
-: MOVNTI     ( dest src -- ) { HEX: 0f HEX: c3 } (2-operand) ;
+: MOVNTI     ( dest src -- ) swap { HEX: 0f HEX: c3 } (2-operand) ;
 
 : PINSRW     ( dest src imm -- ) HEX: c4 HEX: 66 3-operand-rm-sse ;
 : SHUFPS     ( dest src imm -- ) 4shuffler HEX: c6 f       3-operand-rm-sse ;
@@ -793,4 +789,3 @@ PRIVATE>
 
 : HWNT ( -- ) HEX: 2e , ; ! Hint branch Weakly Not Taken
 : HST  ( -- ) HEX: 3e , ; ! Hint branch Strongly Taken
-