Comparison operations

basis/compiler/codegen/codegen.factor

@@ -21,6 +21,9 @@ SYMBOL: registers
 : register ( vreg -- operand )
     registers get at [ "Bad value" throw ] unless* ;
 
+: ?register ( obj -- operand )
+    dup vreg? [ register ] when ;
+
 : generate-insns ( insns -- code )
     [
         [
@@ -64,7 +67,7 @@ SYMBOL: labels
     labels get [ drop <label> ] cache ;
 
 M: ##load-immediate generate-insn
-    [ dst>> register ] [ obj>> ] bi %load-immediate ;
+    [ dst>> register ] [ val>> ] bi %load-immediate ;
 
 M: ##load-indirect generate-insn
     [ dst>> register ] [ obj>> ] bi %load-indirect ;
@@ -94,7 +97,7 @@ M: ##dispatch generate-insn
     {
         [ dst>> register ]
         [ obj>> register ]
-        [ slot>> dup vreg? [ register ] when ]
+        [ slot>> ?register ]
         [ tag>> ]
     } cleave ; inline
 
@@ -108,7 +111,7 @@ M: ##slot-imm generate-insn
     {
         [ src>> register ]
         [ obj>> register ]
-        [ slot>> dup vreg? [ register ] when ]
+        [ slot>> ?register ]
         [ tag>> ]
     } cleave ; inline
 
@@ -122,7 +125,9 @@ M: ##set-slot-imm generate-insn
     [ dst>> register ] [ src>> register ] bi ; inline
 
 : dst/src1/src2 ( insn -- dst src1 src2 )
-    [ dst>> register ] [ src1>> register ] [ src2>> register ] tri ; inline
+    [ dst>> register ]
+    [ src1>> register ]
+    [ src2>> ?register ] tri ; inline
 
 M: ##add     generate-insn dst/src1/src2 %add     ;
 M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
@@ -152,15 +157,15 @@ M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
 M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
 M: ##div-float generate-insn dst/src1/src2 %div-float ;
 
-M: ##integer>float generate-insn dst/src/temp %integer>float ;
+M: ##integer>float generate-insn dst/src %integer>float ;
 M: ##float>integer generate-insn dst/src %float>integer ;
 
-M: ##copy             generate-insn dst/src %copy             ;
+M: ##copy             generate-insn dst/src %copy ;
-M: ##copy-float       generate-insn dst/src %copy-float       ;
+M: ##copy-float       generate-insn dst/src %copy-float ;
-M: ##unbox-float      generate-insn dst/src %unbox-float      ;
+M: ##unbox-float      generate-insn dst/src %unbox-float ;
-M: ##unbox-any-c-ptr  generate-insn dst/src %unbox-any-c-ptr  ;
+M: ##unbox-any-c-ptr  generate-insn dst/src/temp %unbox-any-c-ptr ;
-M: ##box-float        generate-insn dst/src/temp %box-float   ;
+M: ##box-float        generate-insn dst/src/temp %box-float ;
-M: ##box-alien        generate-insn dst/src/temp %box-alien   ;
+M: ##box-alien        generate-insn dst/src/temp %box-alien ;
 
 M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
 M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
@@ -172,7 +177,7 @@ M: ##alien-cell       generate-insn dst/src %alien-cell       ;
 M: ##alien-float      generate-insn dst/src %alien-float      ;
 M: ##alien-double     generate-insn dst/src %alien-double     ;
 
-: >alien-setter< [ src>> register ] [ value>> register ] bi ;
+: >alien-setter< [ src>> register ] [ value>> register ] bi ; inline
 
 M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
 M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
@@ -461,13 +466,25 @@ M: _label generate-insn
 M: _branch generate-insn
     label>> lookup-label %jump-label ;
 
+: >compare< ( insn -- label cc src1 src2 )
+    {
+        [ dst>> register ]
+        [ cc>> ]
+        [ src1>> register ]
+        [ src2>> ?register ]
+    } cleave ; inline
+
+M: ##compare generate-insn >compare< %compare ;
+M: ##compare-imm generate-insn >compare< %compare-imm ;
+M: ##compare-float generate-insn >compare< %compare-float ;
+
 : >binary-branch< ( insn -- label cc src1 src2 )
     {
         [ label>> lookup-label ]
         [ cc>> ]
         [ src1>> register ]
-        [ src2>> dup vreg? [ register ] when ]
+        [ src2>> ?register ]
-    } cleave ;
+    } cleave ; inline
 
 M: _compare-branch generate-insn
     >binary-branch< %compare-branch ;

basis/cpu/architecture/architecture.factor

@@ -74,7 +74,7 @@ HOOK: %sar-imm cpu ( dst src1 src2 -- )
 HOOK: %not     cpu ( dst src -- )
 
 HOOK: %integer>bignum cpu ( dst src temp -- )
-HOOK: %bignum>integer cpu ( dst src temp -- )
+HOOK: %bignum>integer cpu ( dst src -- )
 
 HOOK: %add-float cpu ( dst src1 src2 -- )
 HOOK: %sub-float cpu ( dst src1 src2 -- )
@@ -115,6 +115,10 @@ HOOK: %gc cpu ( -- )
 HOOK: %prologue cpu ( n -- )
 HOOK: %epilogue cpu ( n -- )
 
+HOOK: %compare cpu ( dst cc src1 src2 -- )
+HOOK: %compare-imm cpu ( dst cc src1 src2 -- )
+HOOK: %compare-float cpu ( dst cc src1 src2 -- )
+
 HOOK: %compare-branch cpu ( label cc src1 src2 -- )
 HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
 HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
@@ -193,7 +197,7 @@ M: stack-params param-reg drop ;
 M: stack-params param-regs drop f ;
 
 : if-small-struct ( n size true false -- ? )
-    [ 2dup [ not ] [ struct-small-enough? ] bi and ] 2dip
+    [ 2dup [ not ] [ struct-small-enough? ] bi* and ] 2dip
     [ '[ nip @ ] ] dip if ;
     inline
 

basis/cpu/x86/32/32.factor

@@ -74,8 +74,12 @@ M: float-regs store-return-reg
     [ [ align-sub ] [ call ] bi* ]
     [ [ align-add ] [ drop ] bi* ] 2bi ; inline
 
-M: x86.32 %load-indirect
+M: x86.64 rel-literal-x86 rc-absolute-cell rel-literal ;
-    0 [] MOV rc-absolute-cell rel-literal ;
+
+M: x86.32 %prologue ( n -- )
+    dup PUSH
+    0 PUSH rc-absolute-cell rel-this
+    stack-reg swap 3 cells - SUB ;
 
 M: object %load-param-reg 3drop ;
 

basis/cpu/x86/64/64.factor

@@ -32,8 +32,13 @@ M: float-regs return-reg drop XMM0 ;
 M: float-regs param-regs
     drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
-M: x86.64 %load-indirect
+M: x86.64 rel-literal-x86 rc-relative rel-literal ;
-    0 [] MOV rc-relative rel-literal ;
+
+M: x86.64 %prologue ( n -- )
+    temp-reg-1 0 MOV rc-absolute-cell rel-this
+    dup PUSH
+    temp-reg-1 PUSH
+    stack-reg swap 3 cells - SUB ;
 
 M: stack-params %load-param-reg
     drop
@@ -53,8 +58,8 @@ M: stack-params %save-param-reg
     ] with-scope ; inline
 
 ! The ABI for passing structs by value is pretty messed up
-"void*" c-type clone "__stack_value" define-primitive-type
+<< "void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type (>>reg-class)
+stack-params "__stack_value" c-type (>>reg-class) >>
 
 : struct-types&offset ( struct-type -- pairs )
     fields>> [

basis/cpu/x86/architecture/architecture.factor

@@ -14,6 +14,10 @@ HOOK: temp-reg-2 cpu ( -- reg )
 
 M: x86 %load-immediate MOV ;
 
+HOOK: rel-literal-x86 cpu ( literal -- )
+
+M: x86 %load-indirect swap 0 [] MOV rel-literal-x86 ;
+
 HOOK: ds-reg cpu ( -- reg )
 HOOK: rs-reg cpu ( -- reg )
 
@@ -178,7 +182,7 @@ M: x86 %copy-float MOVSD ;
 M: x86 %unbox-float ( dst src -- )
     float-offset [+] MOVSD ;
 
-M:: x86 %unbox-any-c-ptr ( dst src dst temp -- )
+M:: x86 %unbox-any-c-ptr ( dst src temp -- )
     [
         { "is-byte-array" "end" "start" } [ define-label ] each
         dst 0 MOV
@@ -269,9 +273,9 @@ M:: x86 %box-alien ( dst src temp -- )
 
 : small-reg ( reg size -- reg' )
     {
-        { 1 small-reg-1 }
+        { 1 [ small-reg-1 ] }
-        { 2 small-reg-2 }
+        { 2 [ small-reg-2 ] }
-        { 4 small-reg-4 }
+        { 4 [ small-reg-4 ] }
     } case ;
 
 : small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
@@ -287,7 +291,7 @@ M:: x86 %box-alien ( dst src temp -- )
     #! call the quot with that. Otherwise, we find a small
     #! register that is not equal to src, and call quot, saving
     #! and restoring the small register.
-    dst small-regs memq? [ src quot call ] [
+    dst small-regs memq? [ dst src quot call ] [
         src small-reg-that-isn't
         [ src quot call ]
         with-save/restore
@@ -381,17 +385,39 @@ HOOK: stack-reg cpu ( -- reg )
 : decr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
 
-M: x86 %prologue ( n -- )
-    temp-reg-1 0 MOV rc-absolute-cell rel-this
-    dup PUSH
-    temp-reg-1 PUSH
-    stack-reg swap 3 cells - SUB ;
-
 : incr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
 
 M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
 
+: %boolean ( dst word -- )
+    over \ f tag-number MOV
+    0 [] swap execute
+    \ t rel-literal-x86 ; inline
+
+M: x86 %compare ( dst cc src1 src2 -- )
+    CMP {
+        { cc< [ \ CMOVL %boolean ] }
+        { cc<= [ \ CMOVLE %boolean ] }
+        { cc> [ \ CMOVG %boolean ] }
+        { cc>= [ \ CMOVGE %boolean ] }
+        { cc= [ \ CMOVE %boolean ] }
+        { cc/= [ \ CMOVNE %boolean ] }
+    } case ;
+
+M: x86 %compare-imm ( dst cc src1 src2 -- )
+    %compare ;
+
+M: x86 %compare-float ( dst cc src1 src2 -- )
+    UCOMISD {
+        { cc< [ \ CMOVB %boolean ] }
+        { cc<= [ \ CMOVBE %boolean ] }
+        { cc> [ \ CMOVA %boolean ] }
+        { cc>= [ \ CMOVAE %boolean ] }
+        { cc= [ \ CMOVE %boolean ] }
+        { cc/= [ \ CMOVNE %boolean ] }
+    } case ;
+
 M: x86 %compare-branch ( label cc src1 src2 -- )
     CMP {
         { cc< [ JL ] }
@@ -399,6 +425,7 @@ M: x86 %compare-branch ( label cc src1 src2 -- )
         { cc> [ JG ] }
         { cc>= [ JGE ] }
         { cc= [ JE ] }
+        { cc/= [ JNE ] }
     } case ;
 
 M: x86 %compare-imm-branch ( label src1 src2 cc -- )
@@ -411,6 +438,7 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
         { cc> [ JA ] }
         { cc>= [ JAE ] }
         { cc= [ JE ] }
+        { cc/= [ JNE ] }
     } case ;
 
 : stack@ ( n -- op ) stack-reg swap [+] ;