Merge Phil Dawes' VM work

[factor.git] / basis / cpu / x86 / x86.factor

diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 299d3db84c46ebdab8867713bf6ed703469425e7..97bd2f78ded9c8ef7a4699b9562f42e25c814b46 100644 (file)
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -4,14 +4,14 @@ USING: accessors assocs alien alien.c-types arrays strings
 cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
 cpu.architecture kernel kernel.private math memory namespaces make
 sequences words system layouts combinators math.order fry locals
-compiler.constants byte-arrays
+compiler.constants vm byte-arrays
 compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.intrinsics
 compiler.cfg.comparisons
 compiler.cfg.stack-frame
-compiler.codegen
 compiler.codegen.fixup ;
+FROM: math => float ;
 IN: cpu.x86
 
 << enable-fixnum-log2 >>
@@ -251,8 +251,8 @@ M:: x86 %unbox-vector ( dst src rep -- )
 
 M: x86 %broadcast-vector ( dst src rep -- )
     {
-        { float-4-rep [ [ MOVAPS ] [ drop dup 0 SHUFPS ] 2bi ] }
-        { double-2-rep [ [ MOVAPD ] [ drop dup 0 SHUFPD ] 2bi ] }
+        { float-4-rep [ [ MOVSS ] [ drop dup 0 SHUFPS ] 2bi ] }
+        { double-2-rep [ [ MOVSD ] [ drop dup UNPCKLPD ] 2bi ] }
     } case ;
 
 M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
@@ -263,7 +263,7 @@ M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
                 dst src1 MOVSS
                 dst src2 UNPCKLPS
                 src3 src4 UNPCKLPS
-                dst src3 HEX: 44 SHUFPS
+                dst src3 MOVLHPS
             ]
         }
     } case ;
@@ -273,8 +273,8 @@ M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
         {
             double-2-rep
             [
-                dst src1 MOVAPD
-                dst src2 0 SHUFPD
+                dst src1 MOVSD
+                dst src2 UNPCKLPD
             ]
         }
     } case ;
@@ -555,9 +555,13 @@ M: x86 %shl [ SHL ] emit-shift ;
 M: x86 %shr [ SHR ] emit-shift ;
 M: x86 %sar [ SAR ] emit-shift ;
 
+M: x86 %vm-field-ptr ( dst field -- )
+    [ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ]
+    [ vm-field-offset ADD ] 2bi ;
+
 : load-zone-ptr ( reg -- )
     #! Load pointer to start of zone array
-    0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
+    "nursery" %vm-field-ptr ;
 
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
     [ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
@@ -577,18 +581,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- )
     dst class store-tagged
     nursery-ptr size inc-allot-ptr ;
 
+
 M:: x86 %write-barrier ( src card# table -- )
     #! Mark the card pointed to by vreg.
     ! Mark the card
     card# src MOV
     card# card-bits SHR
-    table "cards_offset" f %alien-global
+    table "cards_offset" %vm-field-ptr
     table table [] MOV
     table card# [+] card-mark <byte> MOV
 
     ! Mark the card deck
     card# deck-bits card-bits - SHR
-    table "decks_offset" f %alien-global
+    table "decks_offset" %vm-field-ptr
     table table [] MOV
     table card# [+] card-mark <byte> MOV ;
 
@@ -610,11 +615,10 @@ M:: x86 %call-gc ( gc-root-count -- )
     ! Pass number of roots as second parameter
     param-reg-2 gc-root-count MOV
     ! Call GC
-    %prepare-alien-invoke
-    "inline_gc" f %alien-invoke ;
+    "inline_gc" %vm-invoke-3rd-arg ; 
 
-M: x86 %alien-global
-    [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
+M: x86 %alien-global ( dst symbol library -- )
+    [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;    
 
 M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
 
@@ -623,7 +627,7 @@ M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
     temp 0 MOV \ t rc-absolute-cell rel-immediate
     dst temp word execute ; inline
 
-M: x86 %compare ( dst src1 src2 cc temp -- )
+M:: x86 %compare ( dst src1 src2 cc temp -- )
     src1 src2 CMP
     cc order-cc {
         { cc<  [ dst temp \ CMOVL %boolean ] }
@@ -658,23 +662,29 @@ M: x86 %compare-imm ( dst src1 src2 cc temp -- )
         "no-move" resolve-label
     ] with-scope ;
 
-M:: x86 %compare-float ( dst src1 src2 cc temp -- )
+:: (%compare-float) ( dst src1 src2 cc temp compare -- )
     cc {
-        { cc<    [ src2 src1  COMISD dst temp \ CMOVA  %boolean ] }
-        { cc<=   [ src2 src1  COMISD dst temp \ CMOVAE %boolean ] }
-        { cc>    [ src1 src2  COMISD dst temp \ CMOVA  %boolean ] }
-        { cc>=   [ src1 src2  COMISD dst temp \ CMOVAE %boolean ] }
-        { cc=    [ src1 src2 UCOMISD dst temp \ %cmov-float= %boolean ] }
-        { cc<>   [ src1 src2  COMISD dst temp \ CMOVNE %boolean ] }
-        { cc<>=  [ src1 src2  COMISD dst temp \ CMOVNP %boolean ] }
-        { cc/<   [ src2 src1 UCOMISD dst temp \ CMOVBE %boolean ] }
-        { cc/<=  [ src2 src1 UCOMISD dst temp \ CMOVB  %boolean ] }
-        { cc/>   [ src1 src2 UCOMISD dst temp \ CMOVBE %boolean ] }
-        { cc/>=  [ src1 src2 UCOMISD dst temp \ CMOVB  %boolean ] }
-        { cc/=   [ src1 src2 UCOMISD dst temp \ %cmov-float/= %boolean ] }
-        { cc/<>  [ src1 src2 UCOMISD dst temp \ CMOVE  %boolean ] }
-        { cc/<>= [ src1 src2 UCOMISD dst temp \ CMOVP  %boolean ] }
-    } case ;
+        { cc<    [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA  %boolean ] }
+        { cc<=   [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
+        { cc>    [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA  %boolean ] }
+        { cc>=   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
+        { cc=    [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= %boolean ] }
+        { cc<>   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE %boolean ] }
+        { cc<>=  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP %boolean ] }
+        { cc/<   [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
+        { cc/<=  [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB  %boolean ] }
+        { cc/>   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
+        { cc/>=  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB  %boolean ] }
+        { cc/=   [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= %boolean ] }
+        { cc/<>  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE  %boolean ] }
+        { cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP  %boolean ] }
+    } case ; inline
+
+M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
+    \ COMISD (%compare-float) ;
+
+M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
+    \ UCOMISD (%compare-float) ;
 
 M:: x86 %compare-branch ( label src1 src2 cc -- )
     src1 src2 CMP
@@ -701,24 +711,30 @@ M: x86 %compare-imm-branch ( label src1 src2 cc -- )
 : %jump-float/= ( label -- )
     [ JNE ] [ JP ] bi ;
 
-M:: x86 %compare-float-branch ( label src1 src2 cc -- )
+:: (%compare-float-branch) ( label src1 src2 cc compare -- )
     cc {
-        { cc<    [ src2 src1  COMISD label JA  ] }
-        { cc<=   [ src2 src1  COMISD label JAE ] }
-        { cc>    [ src1 src2  COMISD label JA  ] }
-        { cc>=   [ src1 src2  COMISD label JAE ] }
-        { cc=    [ src1 src2 UCOMISD label %jump-float= ] }
-        { cc<>   [ src1 src2  COMISD label JNE ] }
-        { cc<>=  [ src1 src2  COMISD label JNP ] }
-        { cc/<   [ src2 src1 UCOMISD label JBE ] }
-        { cc/<=  [ src2 src1 UCOMISD label JB  ] }
-        { cc/>   [ src1 src2 UCOMISD label JBE ] }
-        { cc/>=  [ src1 src2 UCOMISD label JB  ] }
-        { cc/=   [ src1 src2 UCOMISD label %jump-float/= ] }
-        { cc/<>  [ src1 src2 UCOMISD label JE  ] }
-        { cc/<>= [ src1 src2 UCOMISD label JP  ] }
+        { cc<    [ src2 src1 \ compare execute( a b -- ) label JA  ] }
+        { cc<=   [ src2 src1 \ compare execute( a b -- ) label JAE ] }
+        { cc>    [ src1 src2 \ compare execute( a b -- ) label JA  ] }
+        { cc>=   [ src1 src2 \ compare execute( a b -- ) label JAE ] }
+        { cc=    [ src1 src2 \ compare execute( a b -- ) label %jump-float= ] }
+        { cc<>   [ src1 src2 \ compare execute( a b -- ) label JNE ] }
+        { cc<>=  [ src1 src2 \ compare execute( a b -- ) label JNP ] }
+        { cc/<   [ src2 src1 \ compare execute( a b -- ) label JBE ] }
+        { cc/<=  [ src2 src1 \ compare execute( a b -- ) label JB  ] }
+        { cc/>   [ src1 src2 \ compare execute( a b -- ) label JBE ] }
+        { cc/>=  [ src1 src2 \ compare execute( a b -- ) label JB  ] }
+        { cc/=   [ src1 src2 \ compare execute( a b -- ) label %jump-float/= ] }
+        { cc/<>  [ src1 src2 \ compare execute( a b -- ) label JE  ] }
+        { cc/<>= [ src1 src2 \ compare execute( a b -- ) label JP  ] }
     } case ;
 
+M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- )
+    \ COMISD (%compare-float-branch) ;
+
+M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
+    \ UCOMISD (%compare-float-branch) ;
+
 M:: x86 %spill ( src rep n -- )
     n spill@ src rep copy-register ;
 
@@ -727,16 +743,18 @@ M:: x86 %reload ( dst rep n -- )
 
 M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
 
-M: x86 %prepare-alien-invoke
+M:: x86 %save-context ( temp1 temp2 callback-allowed? -- )
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
-    temp-reg "stack_chain" f %alien-global
-    temp-reg temp-reg [] MOV
-    temp-reg [] stack-reg MOV
-    temp-reg [] cell SUB
-    temp-reg 2 cells [+] ds-reg MOV
-    temp-reg 3 cells [+] rs-reg MOV ;
+    temp1 0 MOV rc-absolute-cell rt-vm rel-fixup
+    temp1 temp1 "stack_chain" vm-field-offset [+] MOV
+    temp2 stack-reg cell neg [+] LEA
+    temp1 [] temp2 MOV
+    callback-allowed? [
+        temp1 2 cells [+] ds-reg MOV
+        temp1 3 cells [+] rs-reg MOV
+    ] when ;
 
 M: x86 value-struct? drop t ;