removing non-branching fixnum comparison vops

library/compiler/intrinsics.factor

@@ -105,24 +105,35 @@ sequences vectors words ;
 : binary-op ( node op -- )
     >r load-inputs first2 swap dup r> execute , out-1 ; inline
 
-[
+{
-    [[ fixnum+       %fixnum+       ]]
+    { fixnum+       %fixnum+       }
-    [[ fixnum-       %fixnum-       ]]
+    { fixnum-       %fixnum-       }
-    [[ fixnum*       %fixnum*       ]]
+    { fixnum*       %fixnum*       }
-    [[ fixnum/i      %fixnum/i      ]]
+    { fixnum/i      %fixnum/i      }
-    [[ fixnum-bitand %fixnum-bitand ]]
+    { fixnum-bitand %fixnum-bitand }
-    [[ fixnum-bitor  %fixnum-bitor  ]]
+    { fixnum-bitor  %fixnum-bitor  }
-    [[ fixnum-bitxor %fixnum-bitxor ]]
+    { fixnum-bitxor %fixnum-bitxor }
-    [[ fixnum<=      %fixnum<=      ]]
+} [
-    [[ fixnum<       %fixnum<       ]]
+    first2 [ literalize , \ binary-op , ] [ ] make
-    [[ fixnum>=      %fixnum>=      ]]
-    [[ fixnum>       %fixnum>       ]]
-    [[ eq?           %eq?           ]]
-] [
-    uncons [ literalize , \ binary-op , ] [ ] make
     "intrinsic" set-word-prop
 ] each
 
+: binary-jump ( node label op -- )
+    >r >r node-in-d values>vregs
+    dup length neg %inc-d , first2 swap
+    r> r> execute , ; inline
+
+{
+    { fixnum<= %jump-fixnum<= }
+    { fixnum<  %jump-fixnum<  }
+    { fixnum>= %jump-fixnum>= }
+    { fixnum>  %jump-fixnum>  }
+    { eq?      %jump-eq?      }
+} [
+    first2 [ literalize , \ binary-jump , ] [ ] make
+    "ifte-intrinsic" set-word-prop
+] each
+
 \ fixnum-mod [
     ! This is not clever. Because of x86, %fixnum-mod is
     ! hard-coded to put its output in vreg 2, which happends to

library/compiler/linearizer.factor

@@ -35,24 +35,33 @@ M: #label linearize* ( node -- )
 
 : intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
 
+: ifte-intrinsic ( #call -- quot )
+    dup node-successor #ifte?
+    [ node-param "ifte-intrinsic" word-prop ] [ drop f ] ifte ;
+
+: linearize-ifte ( node label -- )
+    #! Assume the quotation emits a VOP that jumps to the label
+    #! if some condition holds; we linearize the false branch,
+    #! then the label, then the true branch.
+    >r node-children first2 linearize* r> %label , linearize* ;
+
 M: #call linearize* ( node -- )
-    dup intrinsic [
+    dup ifte-intrinsic [
-        dupd call linearize-next
+        >r <label> 2dup r> call
+        >r node-successor r> linearize-ifte
     ] [
-        \ %call \ %jump ?tail-call
+        dup intrinsic [
+            dupd call linearize-next
+        ] [
+            \ %call \ %jump ?tail-call
+        ] ifte*
     ] ifte* ;
 
 M: #call-label linearize* ( node -- )
     \ %call-label \ %jump-label ?tail-call ;
 
-: ifte-head ( label -- ) in-1  -1 %inc-d , 0 %jump-t , ;
-
 M: #ifte linearize* ( node -- )
-    node-children first2
+    <label> dup in-1  -1 %inc-d , 0 %jump-t , linearize-ifte ;
-    <label> dup ifte-head
-    swap linearize* ( false branch )
-    %label , ( branch target of BRANCH-T )
-    linearize* ( true branch ) ;
 
 : dispatch-head ( vtable -- label/code )
     #! Output the jump table insn and return a list of

library/compiler/ppc/fixnum.factor

@@ -141,37 +141,12 @@ M: %fixnum>> generate-node ( vop -- )
 M: %fixnum-sgn generate-node ( vop -- )
     dest/src dupd 31 SRAWI dup untag ;
 
-: compare ( vop -- )
-    dup 1 vop-in v>operand swap 0 vop-in dup integer? [
-        0 -rot address CMPI
-    ] [
-        0 swap v>operand CMP
-    ] ifte ;
-
-: load-boolean ( dest cond -- )
-    #! Compile this after a conditional jump to store f or t
-    #! in dest depending on the jump being taken or not.
-    <label> "true" set
-    <label> "end" set
-    "true" get swap execute
-    f address over LI
-    "end" get B
-    "true" get save-xt
-    t load-indirect
-    "end" get save-xt ; inline
-
-: fixnum-pred ( vop word -- dest )
-    >r [ compare ] keep 0 vop-out v>operand r> load-boolean ;
-    inline
-
-M: %fixnum<  generate-node ( vop -- ) \ BLT fixnum-pred ;
-M: %fixnum<= generate-node ( vop -- ) \ BLE fixnum-pred ;
-M: %fixnum>  generate-node ( vop -- ) \ BGT fixnum-pred ;
-M: %fixnum>= generate-node ( vop -- ) \ BGE fixnum-pred ;
-M: %eq?      generate-node ( vop -- ) \ BEQ fixnum-pred ;
-
 : fixnum-jump ( vop -- label )
-    [ compare ] keep vop-label ;
+    [
+        dup 1 vop-in v>operand
+        swap 0 vop-in v>operand
+        0 swap CMP
+    ] keep vop-label ;
 
 M: %jump-fixnum<  generate-node ( vop -- ) fixnum-jump BLT ;
 M: %jump-fixnum<= generate-node ( vop -- ) fixnum-jump BLE ;

library/compiler/vops.factor

@@ -261,17 +261,6 @@ TUPLE: %fixnum-bitnot ;
 C: %fixnum-bitnot make-vop ; : %fixnum-bitnot 2-vop <%fixnum-bitnot> ;
 M: %fixnum-bitnot basic-block? drop t ;
 
-TUPLE: %fixnum<= ;
-C: %fixnum<= make-vop ;      : %fixnum<= 3-vop <%fixnum<=> ;
-TUPLE: %fixnum< ;
-C: %fixnum< make-vop ;       : %fixnum< 3-vop <%fixnum<> ;
-TUPLE: %fixnum>= ;
-C: %fixnum>= make-vop ;      : %fixnum>= 3-vop <%fixnum>=> ;
-TUPLE: %fixnum> ;
-C: %fixnum> make-vop ;       : %fixnum> 3-vop <%fixnum>> ;
-TUPLE: %eq? ;
-C: %eq? make-vop ;           : %eq? 3-vop <%eq?> ;
-
 ! At the VOP level, the 'shift' operation is split into five
 ! distinct operations:
 ! - shifts with a large positive count: calls runtime to make
@@ -293,7 +282,6 @@ TUPLE: %fixnum-sgn ;
 C: %fixnum-sgn make-vop ; : %fixnum-sgn src/dest-vop <%fixnum-sgn> ;
 M: %fixnum-sgn basic-block? drop t ;
 
-
 ! Integer comparison followed by a conditional branch is
 ! optimized
 TUPLE: %jump-fixnum<= ;
@@ -316,20 +304,6 @@ TUPLE: %jump-eq? ;
 C: %jump-eq? make-vop ;     
 : %jump-eq? 2-in/label-vop <%jump-eq?> ;
 
-: fast-branch ( class -- class )
-    {{
-        [[ %fixnum<= %jump-fixnum<= ]]
-        [[ %fixnum<  %jump-fixnum<  ]]
-        [[ %fixnum>= %jump-fixnum>= ]]
-        [[ %fixnum>  %jump-fixnum>  ]]
-        [[ %eq?      %jump-eq?      ]]
-    }} hash ;
-
-PREDICATE: tuple fast-branch
-    #! Class of VOPs whose class is a key in fast-branch
-    #! hashtable.
-    class fast-branch ;
-
 ! some slightly optimized inline assembly
 TUPLE: %type ;
 C: %type make-vop ;

library/compiler/x86/fixnum.factor

@@ -157,36 +157,6 @@ M: %fixnum-sgn generate-node
     ! give it a fixnum tag.
     0 vop-out v>operand tag-bits SHL ;
 
-: load-boolean ( dest cond -- )
-    #! Compile this after a conditional jump to store f or t
-    #! in dest depending on the jump being taken or not.
-    <label> "true" set
-    <label> "end" set
-    "true" get swap execute
-    dup f address MOV
-    "end" get JMP
-    "true" get save-xt
-    t load-indirect
-    "end" get save-xt ; inline
-
-: fixnum-compare ( vop -- dest )
-    dup 0 vop-out v>operand dup rot 0 vop-in v>operand CMP ;
-
-M: %fixnum< generate-node ( vop -- )
-    fixnum-compare  \ JL  load-boolean ;
-
-M: %fixnum<= generate-node ( vop -- )
-    fixnum-compare  \ JLE  load-boolean ;
-
-M: %fixnum> generate-node ( vop -- )
-    fixnum-compare  \ JG  load-boolean ;
-
-M: %fixnum>= generate-node ( vop -- )
-    fixnum-compare  \ JGE  load-boolean ;
-
-M: %eq? generate-node ( vop -- )
-    fixnum-compare  \ JE  load-boolean ;
-
 : fixnum-jump ( vop -- label )
     dup 1 vop-in v>operand over 0 vop-in v>operand CMP
     vop-label ;

library/inference/known-words.factor

@@ -30,14 +30,14 @@ memory parser sequences strings vectors words prettyprint ;
 \ eq? t "flushable" set-word-prop
 \ eq? t "foldable" set-word-prop
 
-! : manual-branch ( word -- )
+: manual-branch ( word -- )
-!     dup "infer-effect" word-prop consume/produce
+    dup "infer-effect" word-prop consume/produce
-!     [ [ t ] [ f ] ifte ] infer-quot ;
+    [ [ t ] [ f ] ifte ] infer-quot ;
-! 
+
-! { fixnum<= fixnum< fixnum>= fixnum> eq? } [
+{ fixnum<= fixnum< fixnum>= fixnum> eq? } [
-!     dup dup literalize [ manual-branch ] cons
+    dup dup literalize [ manual-branch ] cons
-!     "infer" set-word-prop
+    "infer" set-word-prop
-! ] each
+] each
 
 ! Primitive combinators
 \ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop

library/test/compiler/intrinsics.factor

@@ -172,6 +172,7 @@ math-internals test words ;
 [ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-1 2nip ] unit-test
 
 ! regression
-: blah over cons? [ "x" get >r 2cdr r> ] [ 2drop f f f ] ifte ; compiled
+: bleh 3 ;
+: blah over cons? [ bleh >r 2cdr r> ] [ 2drop f f f ] ifte ; compiled
 
-[ f ] [ f "x" set [ 1 2 3 ] [ 1 3 2 ] blah drop 2car = ] unit-test
+[ f ] [ f [ 1 2 3 ] [ 1 3 2 ] blah drop 2car = ] unit-test