Debugging untagged fixnums

basis/compiler/cfg/builder/builder.factor

@@ -123,7 +123,7 @@ M: #recursive emit-node
     and ;
 
 : emit-trivial-if ( -- )
-    ds-pop f cc/= ^^compare-imm ds-push ;
+    [ f cc/= ^^compare-imm ] unary-op ;
 
 : trivial-not-if? ( #if -- ? )
     children>> first2
@@ -132,7 +132,7 @@ M: #recursive emit-node
     and ;
 
 : emit-trivial-not-if ( -- )
-    ds-pop f cc= ^^compare-imm ds-push ;
+    [ f cc= ^^compare-imm ] unary-op ;
 
 : emit-actual-if ( #if -- )
     ! Inputs to the final instruction need to be copied because of

basis/compiler/cfg/checker/checker.factor

@@ -27,6 +27,8 @@ ERROR: last-insn-not-a-jump bb ;
         [ ##dispatch? ]
         [ ##compare-branch? ]
         [ ##compare-imm-branch? ]
+        [ ##compare-integer-branch? ]
+        [ ##compare-integer-imm-branch? ]
         [ ##compare-float-ordered-branch? ]
         [ ##compare-float-unordered-branch? ]
         [ ##fixnum-add? ]

basis/compiler/cfg/hats/hats.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays combinators.short-circuit
+USING: accessors alien arrays byte-arrays classes.algebra
-kernel layouts math namespaces sequences combinators splitting
+combinators.short-circuit kernel layouts math namespaces
-parser effects words cpu.architecture compiler.cfg.registers
+sequences combinators splitting parser effects words
+cpu.architecture compiler.constants compiler.cfg.registers
 compiler.cfg.instructions compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.hats
 

basis/compiler/cfg/instructions/instructions.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors arrays kernel sequences namespaces words
-math math.order layouts classes.algebra classes.union
+math math.order layouts classes.union compiler.units alien
-compiler.units alien byte-arrays compiler.constants combinators
+byte-arrays combinators compiler.cfg.registers
-compiler.cfg.registers compiler.cfg.instructions.syntax ;
+compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.instructions
 
 <<
@@ -23,20 +23,20 @@ TUPLE: pure-insn < insn ;
 ! Constants
 INSN: ##load-integer
 def: dst/int-rep
-constant: val ;
+constant: val/int-rep ;
 
 INSN: ##load-reference
 def: dst/tagged-rep
-constant: obj ;
+constant: obj/tagged-rep ;
 
 ! These two are inserted by representation selection
 INSN: ##load-tagged
 def: dst/tagged-rep
-constant: val ;
+constant: val/tagged-rep ;
 
 INSN: ##load-double
 def: dst/double-rep
-constant: val ;
+constant: val/double-rep ;
 
 ! Stack operations
 INSN: ##peek
@@ -115,7 +115,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##add-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##sub
 def: dst/int-rep
@@ -124,7 +124,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##sub-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##mul
 def: dst/int-rep
@@ -133,7 +133,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##mul-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##and
 def: dst/int-rep
@@ -142,7 +142,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##and-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##or
 def: dst/int-rep
@@ -151,7 +151,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##or-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##xor
 def: dst/int-rep
@@ -160,7 +160,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##xor-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##shl
 def: dst/int-rep
@@ -169,7 +169,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##shl-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##shr
 def: dst/int-rep
@@ -178,7 +178,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##shr-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##sar
 def: dst/int-rep
@@ -187,7 +187,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##sar-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##min
 def: dst/int-rep
@@ -691,14 +691,14 @@ INSN: ##phi
 def: dst
 literal: inputs ;
 
-! Conditionals
+! Tagged conditionals
 INSN: ##compare-branch
 use: src1/tagged-rep src2/tagged-rep
 literal: cc ;
 
 INSN: ##compare-imm-branch
 use: src1/tagged-rep
-constant: src2
+constant: src2/tagged-rep
 literal: cc ;
 
 PURE-INSN: ##compare
@@ -710,10 +710,34 @@ temp: temp/int-rep ;
 PURE-INSN: ##compare-imm
 def: dst/tagged-rep
 use: src1/tagged-rep
-constant: src2
+constant: src2/tagged-rep
 literal: cc
 temp: temp/int-rep ;
 
+! Integer conditionals
+INSN: ##compare-integer-branch
+use: src1/int-rep src2/int-rep
+literal: cc ;
+
+INSN: ##compare-integer-imm-branch
+use: src1/int-rep
+constant: src2/int-rep
+literal: cc ;
+
+PURE-INSN: ##compare-integer
+def: dst/tagged-rep
+use: src1/int-rep src2/int-rep
+literal: cc
+temp: temp/int-rep ;
+
+PURE-INSN: ##compare-integer-imm
+def: dst/tagged-rep
+use: src1/int-rep
+constant: src2/int-rep
+literal: cc
+temp: temp/int-rep ;
+
+! Float conditionals
 INSN: ##compare-float-ordered-branch
 use: src1/double-rep src2/double-rep
 literal: cc ;
@@ -770,7 +794,7 @@ literal: label ;
 INSN: _loop-entry ;
 
 INSN: _dispatch
-use: src/int-rep
+use: src
 temp: temp ;
 
 INSN: _dispatch-label
@@ -778,46 +802,44 @@ literal: label ;
 
 INSN: _compare-branch
 literal: label
-use: src1/tagged-rep src2/tagged-rep
+use: src1 src2
 literal: cc ;
 
 INSN: _compare-imm-branch
 literal: label
-use: src1/tagged-rep
+use: src1
 constant: src2
 literal: cc ;
 
 INSN: _compare-float-unordered-branch
 literal: label
-use: src1/tagged-rep src2/tagged-rep
+use: src1 src2
 literal: cc ;
 
 INSN: _compare-float-ordered-branch
 literal: label
-use: src1/tagged-rep src2/tagged-rep
+use: src1 src2
 literal: cc ;
 
 ! Overflowing arithmetic
 INSN: _fixnum-add
 literal: label
-def: dst/tagged-rep
+def: dst
-use: src1/tagged-rep src2/tagged-rep ;
+use: src1 src2 ;
 
 INSN: _fixnum-sub
 literal: label
-def: dst/tagged-rep
+def: dst
-use: src1/tagged-rep src2/tagged-rep ;
+use: src1 src2 ;
 
 INSN: _fixnum-mul
 literal: label
-def: dst/tagged-rep
+def: dst
-use: src1/tagged-rep src2/int-rep ;
+use: src1 src2 ;
 
 TUPLE: spill-slot { n integer } ;
 C: <spill-slot> spill-slot
 
-! These instructions operate on machine registers and not
-! virtual registers
 INSN: _spill
 use: src
 literal: rep dst ;
@@ -829,6 +851,7 @@ literal: rep src ;
 INSN: _spill-area-size
 literal: n ;
 
+! For GC check insertion
 UNION: ##allocation
 ##allot
 ##box-alien

basis/compiler/cfg/intrinsics/alien/alien.factor

@@ -16,9 +16,10 @@ IN: compiler.cfg.intrinsics.alien
 
 : emit-<displaced-alien> ( node -- )
     dup emit-<displaced-alien>? [
-        [ 2inputs ] dip
+        '[
-        node-input-infos second class>>
+            _ node-input-infos second class>>
-        ^^box-displaced-alien ds-push
+            ^^box-displaced-alien
+        ] binary-op
     ] [ emit-primitive ] if ;
 
 :: inline-alien ( node quot test -- )
@@ -51,11 +52,16 @@ IN: compiler.cfg.intrinsics.alien
 : prepare-alien-setter ( infos -- ptr-vreg offset )
     second prepare-alien-accessor ;
 
-: inline-alien-setter ( node quot -- )
+: inline-alien-integer-setter ( node quot -- )
     '[ prepare-alien-setter ds-pop @ ]
     [ fixnum inline-alien-setter? ]
     inline-alien ; inline
 
+: inline-alien-float-setter ( node quot -- )
+    '[ prepare-alien-setter ds-pop @ ]
+    [ float inline-alien-setter? ]
+    inline-alien ; inline
+
 : inline-alien-cell-setter ( node quot -- )
     '[ [ prepare-alien-setter ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ]
     [ pinned-c-ptr inline-alien-setter? ]
@@ -86,7 +92,7 @@ IN: compiler.cfg.intrinsics.alien
             { 2 [ ##set-alien-integer-2 ] }
             { 4 [ ##set-alien-integer-4 ] }
         } case
-    ] inline-alien-setter ;
+    ] inline-alien-integer-setter ;
 
 : emit-alien-cell-getter ( node -- )
     [ ^^alien-cell ^^box-alien ] inline-alien-getter ;
@@ -108,4 +114,4 @@ IN: compiler.cfg.intrinsics.alien
             { float-rep [ ##set-alien-float ] }
             { double-rep [ ##set-alien-double ] }
         } case
-    ] inline-alien-setter ;
+    ] inline-alien-float-setter ;

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -14,26 +14,24 @@ compiler.cfg.comparisons ;
 IN: compiler.cfg.intrinsics.fixnum
 
 : emit-both-fixnums? ( -- )
-    2inputs
+    [
-    ^^or
+        [ ^^tagged>integer ] bi@
-    tag-mask get ^^and-imm
+        ^^or tag-mask get ^^and-imm
-    0 cc= ^^compare-imm
+        0 cc= ^^compare-integer-imm
-    ds-push ;
+    ] binary-op ;
-
-: binary-fixnum-op ( quot -- )
-    [ 2inputs ] dip call ds-push ; inline
-
-: unary-fixnum-op ( quot -- )
-    [ ds-pop ] dip call ds-push ; inline
 
 : emit-fixnum-left-shift ( -- )
-    [ ^^shl ] binary-fixnum-op ;
+    [ ^^shl ] binary-op ;
 
 : emit-fixnum-right-shift ( -- )
-    [ ^^sar ] binary-fixnum-op ;
+    [
+        [ tag-bits get ^^shl-imm ] dip
+        ^^neg ^^sar
+        tag-bits get ^^sar-imm
+    ] binary-op ;
 
 : emit-fixnum-shift-general ( -- )
-    ds-peek 0 cc> ##compare-imm-branch
+    ds-peek 0 cc> ##compare-integer-imm-branch
     [ emit-fixnum-left-shift ] with-branch
     [ emit-fixnum-right-shift ] with-branch
     2array emit-conditional ;
@@ -46,7 +44,7 @@ IN: compiler.cfg.intrinsics.fixnum
     } cond ;
 
 : emit-fixnum-comparison ( cc -- )
-    '[ _ ^^compare ] binary-fixnum-op ;
+    '[ _ ^^compare-integer ] binary-op ;
 
 : emit-no-overflow-case ( dst -- final-bb )
     [ ds-drop ds-drop ds-push ] with-branch ;

basis/compiler/cfg/intrinsics/float/float.factor

@@ -1,29 +1,17 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.stacks compiler.cfg.hats
+USING: fry kernel compiler.cfg.stacks compiler.cfg.hats
 compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.float
 
-: emit-float-op ( insn -- )
-    [ 2inputs ] dip call ds-push ; inline
-
 : emit-float-ordered-comparison ( cc -- )
-    [ 2inputs ] dip ^^compare-float-ordered ds-push ; inline
+    '[ _ ^^compare-float-ordered ] binary-op ; inline
 
 : emit-float-unordered-comparison ( cc -- )
-    [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline
+    '[ _ ^^compare-float-unordered ] binary-op ; inline
-
-: emit-float>fixnum ( -- )
-    ds-pop ^^float>integer ds-push ;
-
-: emit-fixnum>float ( -- )
-    ds-pop ^^integer>float ds-push ;
-
-: emit-fsqrt ( -- )
-    ds-pop ^^sqrt ds-push ;
 
 : emit-unary-float-function ( func -- )
-    [ ds-pop ] dip ^^unary-float-function ds-push ;
+    '[ _ ^^unary-float-function ] unary-op ;
 
 : emit-binary-float-function ( func -- )
-    [ 2inputs ] dip ^^binary-float-function ds-push ;
+    '[ _ ^^binary-float-function ] binary-op ;

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences kernel combinators cpu.architecture assocs
 compiler.cfg.hats
+compiler.cfg.stacks
 compiler.cfg.instructions
 compiler.cfg.intrinsics.alien
 compiler.cfg.intrinsics.allot
@@ -38,19 +39,19 @@ IN: compiler.cfg.intrinsics
     { math.private:fixnum+ [ drop emit-fixnum+ ] }
     { math.private:fixnum- [ drop emit-fixnum- ] }
     { math.private:fixnum* [ drop emit-fixnum* ] }
-    { math.private:fixnum+fast [ drop [ ^^add ] binary-fixnum-op ] }
+    { math.private:fixnum+fast [ drop [ ^^add ] binary-op ] }
-    { math.private:fixnum-fast [ drop [ ^^sub ] binary-fixnum-op ] }
+    { math.private:fixnum-fast [ drop [ ^^sub ] binary-op ] }
-    { math.private:fixnum*fast [ drop [ ^^mul ] binary-fixnum-op ] }
+    { math.private:fixnum*fast [ drop [ ^^mul ] binary-op ] }
-    { math.private:fixnum-bitand [ drop [ ^^and ] binary-fixnum-op ] }
+    { math.private:fixnum-bitand [ drop [ ^^and ] binary-op ] }
-    { math.private:fixnum-bitor [ drop [ ^^or ] binary-fixnum-op ] }
+    { math.private:fixnum-bitor [ drop [ ^^or ] binary-op ] }
-    { math.private:fixnum-bitxor [ drop [ ^^xor ] binary-fixnum-op ] }
+    { math.private:fixnum-bitxor [ drop [ ^^xor ] binary-op ] }
     { math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
-    { math.private:fixnum-bitnot [ drop [ ^^not ] unary-fixnum-op ] }
+    { math.private:fixnum-bitnot [ drop [ ^^not ] unary-op ] }
     { math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
     { math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
     { math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
     { math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
-    { kernel:eq? [ drop cc= emit-fixnum-comparison ] }
+    { kernel:eq? [ emit-eq ] }
     { slots.private:slot [ emit-slot ] }
     { slots.private:set-slot [ emit-set-slot ] }
     { strings.private:string-nth [ drop emit-string-nth ] }
@@ -83,10 +84,10 @@ IN: compiler.cfg.intrinsics
 
 : enable-float-intrinsics ( -- )
     {
-        { math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
+        { math.private:float+ [ drop [ ^^add-float ] binary-op ] }
-        { math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
+        { math.private:float- [ drop [ ^^sub-float ] binary-op ] }
-        { math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
+        { math.private:float* [ drop [ ^^mul-float ] binary-op ] }
-        { math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+        { math.private:float/f [ drop [ ^^div-float ] binary-op ] }
         { math.private:float< [ drop cc< emit-float-ordered-comparison ] }
         { math.private:float<= [ drop cc<= emit-float-ordered-comparison ] }
         { math.private:float>= [ drop cc>= emit-float-ordered-comparison ] }
@@ -96,8 +97,8 @@ IN: compiler.cfg.intrinsics
         { math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] }
         { math.private:float-u> [ drop cc> emit-float-unordered-comparison ] }
         { math.private:float= [ drop cc= emit-float-unordered-comparison ] }
-        { math.private:float>fixnum [ drop emit-float>fixnum ] }
+        { math.private:float>fixnum [ drop [ ^^float>integer ] unary-op ] }
-        { math.private:fixnum>float [ drop emit-fixnum>float ] }
+        { math.private:fixnum>float [ drop [ ^^integer>float ] unary-op ] }
         { math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
         { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] }
         { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] }
@@ -107,13 +108,13 @@ IN: compiler.cfg.intrinsics
 
 : enable-fsqrt ( -- )
     {
-        { math.libm:fsqrt [ drop emit-fsqrt ] }
+        { math.libm:fsqrt [ drop [ ^^sqrt ] unary-op ] }
     } enable-intrinsics ;
 
 : enable-float-min/max ( -- )
     {
-        { math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
+        { math.floats.private:float-min [ drop [ ^^min-float ] binary-op ] }
-        { math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
+        { math.floats.private:float-max [ drop [ ^^max-float ] binary-op ] }
     } enable-intrinsics ;
 
 : enable-float-functions ( -- )
@@ -143,13 +144,13 @@ IN: compiler.cfg.intrinsics
 
 : enable-min/max ( -- )
     {
-        { math.integers.private:fixnum-min [ drop [ ^^min ] binary-fixnum-op ] }
+        { math.integers.private:fixnum-min [ drop [ ^^min ] binary-op ] }
-        { math.integers.private:fixnum-max [ drop [ ^^max ] binary-fixnum-op ] }
+        { math.integers.private:fixnum-max [ drop [ ^^max ] binary-op ] }
     } enable-intrinsics ;
 
 : enable-log2 ( -- )
     {
-        { math.integers.private:fixnum-log2 [ drop [ ^^log2 ] unary-fixnum-op ] }
+        { math.integers.private:fixnum-log2 [ drop [ ^^log2 ] unary-op ] }
     } enable-intrinsics ;
 
 : emit-intrinsic ( node word -- )

basis/compiler/cfg/intrinsics/misc/misc.factor

@@ -1,15 +1,23 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces layouts sequences kernel math accessors
+USING: accessors classes.algebra layouts kernel math namespaces
-compiler.tree.propagation.info compiler.cfg.stacks
+sequences
-compiler.cfg.hats compiler.cfg.instructions
+compiler.tree.propagation.info
+compiler.cfg.stacks
+compiler.cfg.hats
+compiler.cfg.comparisons
+compiler.cfg.instructions
 compiler.cfg.builder.blocks
 compiler.cfg.utilities ;
 FROM: vm => context-field-offset vm-field-offset ;
 IN: compiler.cfg.intrinsics.misc
 
 : emit-tag ( -- )
-    ds-pop ^^tagged>integer tag-mask get ^^and-imm ds-push ;
+    [ ^^tagged>integer tag-mask get ^^and-imm ] unary-op ;
+
+: emit-eq ( node -- )
+    node-input-infos first2 [ class>> fixnum class<= ] both?
+    [ [ cc= ^^compare-integer ] binary-op ] [ [ cc= ^^compare ] binary-op ] if ;
 
 : special-object-offset ( n -- offset )
     cells "special-objects" vm-field-offset + ;
@@ -37,8 +45,9 @@ IN: compiler.cfg.intrinsics.misc
     ] [ emit-primitive ] ?if ;
 
 : emit-identity-hashcode ( -- )
-    ds-pop ^^tagged>integer
+    [
-    tag-mask get bitnot ^^load-integer ^^and
+        ^^tagged>integer
-    0 ^^alien-cell
+        tag-mask get bitnot ^^load-integer ^^and
-    hashcode-shift ^^shr-imm
+        0 ^^alien-cell
-    ds-push ;
+        hashcode-shift ^^shr-imm
+    ] unary-op ;

basis/compiler/cfg/linearization/linearization.factor

@@ -69,6 +69,12 @@ M: ##compare-branch linearize-insn
 M: ##compare-imm-branch linearize-insn
     binary-conditional _compare-imm-branch emit-branch ;
 
+M: ##compare-integer-branch linearize-insn
+    binary-conditional _compare-branch emit-branch ;
+
+M: ##compare-integer-imm-branch linearize-insn
+    binary-conditional _compare-imm-branch emit-branch ;
+
 M: ##compare-float-ordered-branch linearize-insn
     binary-conditional _compare-float-ordered-branch emit-branch ;
 

basis/compiler/cfg/stacks/stacks.factor

@@ -68,9 +68,14 @@ IN: compiler.cfg.stacks
 : 3inputs ( -- vreg1 vreg2 vreg3 )
     (3inputs) -3 inc-d ;
 
+: binary-op ( quot -- )
+    [ 2inputs ] dip call ds-push ; inline
+
+: unary-op ( quot -- )
+    [ ds-pop ] dip call ds-push ; inline
+
 ! adjust-d/adjust-r: these are called when other instructions which
 ! internally adjust the stack height are emitted, such as ##call and
 ! ##alien-invoke
 : adjust-d ( n -- ) current-height get [ + ] change-d drop ;
 : adjust-r ( n -- ) current-height get [ + ] change-r drop ;
-

basis/compiler/cfg/useless-conditionals/useless-conditionals.factor

@@ -1,19 +1,22 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences math combinators combinators.short-circuit
+USING: kernel accessors sequences math combinators
-classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
+combinators.short-circuit vectors compiler.cfg
+compiler.cfg.instructions compiler.cfg.rpo
 compiler.cfg.utilities ;
 IN: compiler.cfg.useless-conditionals
 
 : delete-conditional? ( bb -- ? )
     {
         [
-            instructions>> last class {
+            instructions>> last {
-                ##compare-branch
+                [ ##compare-branch? ]
-                ##compare-imm-branch
+                [ ##compare-imm-branch? ]
-                ##compare-float-ordered-branch
+                [ ##compare-integer-branch? ]
-                ##compare-float-unordered-branch
+                [ ##compare-integer-imm-branch? ]
-            } member-eq?
+                [ ##compare-float-ordered-branch? ]
+                [ ##compare-float-unordered-branch? ]
+            } 1||
         ]
         [ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
     } 1&& ;

basis/compiler/cfg/value-numbering/comparisons/comparisons.factor

@@ -8,15 +8,57 @@ compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.comparisons
 
-: ##branch-t? ( insn -- ? )
+! Optimizations performed here:
-    dup ##compare-imm-branch? [
+!
-        { [ cc>> cc/= eq? ] [ src2>> not ] } 1&&
+! 1) Eliminating intermediate boolean values when the result of
-    ] [ drop f ] if ; inline
+! a comparison is used by a compare-branch
+! 2) Folding comparisons where both inputs are literal
+! 3) Folding comparisons where both inputs are congruent
+! 4) Converting compare instructions into compare-imm instructions
+
+: fold-compare-imm? ( insn -- ? )
+    src1>> vreg>expr literal-expr? ;
+
+: evaluate-compare-imm ( insn -- ? )
+    [ src1>> vreg>comparand ] [ src2>> ] [ cc>> ] tri
+    {
+        { cc= [ eq? ] }
+        { cc/= [ eq? not ] }
+    } case ;
+
+: fold-compare-integer-imm? ( insn -- ? )
+    src1>> vreg>expr integer-expr? ;
+
+: evaluate-compare-integer-imm ( insn -- ? )
+    [ src1>> vreg>integer ] [ src2>> ] [ cc>> ] tri
+    [ <=> ] dip evaluate-cc ;
+
+: >compare-expr< ( expr -- in1 in2 cc )
+    [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
+
+: >compare-imm-expr< ( expr -- in1 in2 cc )
+    [ src1>> vn>vreg ] [ src2>> vn>comparand ] [ cc>> ] tri ; inline
+
+: >compare-integer-expr< ( expr -- in1 in2 cc )
+    [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
+
+: >compare-integer-imm-expr< ( expr -- in1 in2 cc )
+    [ src1>> vn>vreg ] [ src2>> vn>integer ] [ cc>> ] tri ; inline
+
+: >test-vector-expr< ( expr -- src1 temp rep vcc )
+    {
+        [ src1>> vn>vreg ]
+        [ drop next-vreg ]
+        [ rep>> ]
+        [ vcc>> ]
+    } cleave ; inline
 
 : scalar-compare-expr? ( insn -- ? )
     {
         [ compare-expr? ]
         [ compare-imm-expr? ]
+        [ compare-integer-expr? ]
+        [ compare-integer-imm-expr? ]
         [ compare-float-unordered-expr? ]
         [ compare-float-ordered-expr? ]
     } 1|| ;
@@ -28,61 +70,23 @@ IN: compiler.cfg.value-numbering.comparisons
     } 1|| ;
 
 : rewrite-boolean-comparison? ( insn -- ? )
-    dup ##branch-t? [
-        src1>> vreg>expr general-compare-expr?
-    ] [ drop f ] if ; inline
- 
-: >compare-expr< ( expr -- in1 in2 cc )
-    [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
-
-: >compare-imm-expr< ( expr -- in1 in2 cc )
-    [ src1>> vn>vreg ] [ src2>> vn>integer ] [ cc>> ] tri ; inline
-
-: >test-vector-expr< ( expr -- src1 temp rep vcc )
     {
-        [ src1>> vn>vreg ]
+        [ src1>> vreg>expr general-compare-expr? ]
-        [ drop next-vreg ]
+        [ src2>> not ]
-        [ rep>> ]
+        [ cc>> cc/= eq? ]
-        [ vcc>> ]
+    } 1&& ; inline
-    } cleave ; inline
 
 : rewrite-boolean-comparison ( expr -- insn )
     src1>> vreg>expr {
         { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] }
         { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
+        { [ dup compare-integer-expr? ] [ >compare-integer-expr< \ ##compare-integer-branch new-insn ] }
+        { [ dup compare-integer-imm-expr? ] [ >compare-integer-imm-expr< \ ##compare-integer-imm-branch new-insn ] }
         { [ dup compare-float-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] }
         { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-branch new-insn ] }
         { [ dup test-vector-expr? ] [ >test-vector-expr< \ ##test-vector-branch new-insn ] }
     } cond ;
 
-: rewrite-redundant-comparison? ( insn -- ? )
-    {
-        [ src1>> vreg>expr scalar-compare-expr? ]
-        [ src2>> not ]
-        [ cc>> { cc= cc/= } member? ]
-    } 1&& ; inline
-
-: rewrite-redundant-comparison ( insn -- insn' )
-    [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
-        { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
-        { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
-        { [ dup compare-float-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] }
-        { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered new-insn ] }
-    } cond
-    swap cc= eq? [ [ negate-cc ] change-cc ] when ;
-
-: evaluate-compare-imm ( insn -- ? )
-    [ src1>> vreg>comparand ] [ src2>> ] [ cc>> ] tri
-    2over [ integer? ] both? [ [ <=> ] dip evaluate-cc ] [
-        {
-            { cc= [ eq? ] }
-            { cc/= [ eq? not ] }
-        } case
-    ] if ;
-
-: fold-compare-imm? ( insn -- ? )
-    src1>> vreg>expr literal-expr? ;
-
 : fold-branch ( ? -- insn )
     0 1 ?
     basic-block get [ nth 1vector ] change-successors drop
@@ -98,20 +102,31 @@ M: ##compare-imm-branch rewrite
         [ drop f ]
     } cond ;
 
+: fold-compare-integer-imm-branch ( insn -- insn/f )
+    evaluate-compare-integer-imm fold-branch ;
+
+M: ##compare-integer-imm-branch rewrite
+    {
+        { [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm-branch ] }
+        [ drop f ]
+    } cond ;
+
 : swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
     [ [ swap ] dip swap-cc ] when ; inline
 
+: (>compare-imm-branch) ( insn swap? -- src1 src2 cc )
+    [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] dip swap-compare ; inline
+
 : >compare-imm-branch ( insn swap? -- insn' )
-    [
+    (>compare-imm-branch)
-        [ src1>> ]
-        [ src2>> ]
-        [ cc>> ]
-        tri
-    ] dip
-    swap-compare
     [ vreg>comparand ] dip
     \ ##compare-imm-branch new-insn ; inline
 
+: >compare-integer-imm-branch ( insn swap? -- insn' )
+    (>compare-imm-branch)
+    [ vreg>integer ] dip
+    \ ##compare-integer-imm-branch new-insn ; inline
+
 : self-compare? ( insn -- ? )
     [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
 
@@ -129,19 +144,28 @@ M: ##compare-branch rewrite
         [ drop f ]
     } cond ;
 
+M: ##compare-integer-branch rewrite
+    {
+        { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm-branch ] }
+        { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm-branch ] }
+        { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
+        [ drop f ]
+    } cond ;
+
+: (>compare-imm) ( insn swap? -- dst src1 src2 cc )
+    [ { [ dst>> ] [ src1>> ] [ src2>> ] [ cc>> ] } cleave ] dip
+    swap-compare ; inline
+
 : >compare-imm ( insn swap? -- insn' )
-    [
+    (>compare-imm)
-        {
-            [ dst>> ]
-            [ src1>> ]
-            [ src2>> ]
-            [ cc>> ]
-        } cleave
-    ] dip
-    swap-compare
     [ vreg>comparand ] dip
     next-vreg \ ##compare-imm new-insn ; inline
 
+: >compare-integer-imm ( insn swap? -- insn' )
+    (>compare-imm)
+    [ vreg>integer ] dip
+    next-vreg \ ##compare-integer-imm new-insn ; inline
+
 : >boolean-insn ( insn ? -- insn' )
     [ dst>> ] dip \ ##load-reference new-insn ;
 
@@ -156,6 +180,32 @@ M: ##compare rewrite
         [ drop f ]
     } cond ;
 
+M: ##compare-integer rewrite
+    {
+        { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm ] }
+        { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm ] }
+        { [ dup self-compare? ] [ rewrite-self-compare ] }
+        [ drop f ]
+    } cond ;
+
+: rewrite-redundant-comparison? ( insn -- ? )
+    {
+        [ src1>> vreg>expr scalar-compare-expr? ]
+        [ src2>> not ]
+        [ cc>> { cc= cc/= } member? ]
+    } 1&& ; inline
+
+: rewrite-redundant-comparison ( insn -- insn' )
+    [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
+        { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
+        { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
+        { [ dup compare-integer-expr? ] [ >compare-integer-expr< next-vreg \ ##compare-integer new-insn ] }
+        { [ dup compare-integer-imm-expr? ] [ >compare-integer-imm-expr< next-vreg \ ##compare-integer-imm new-insn ] }
+        { [ dup compare-float-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] }
+        { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered new-insn ] }
+    } cond
+    swap cc= eq? [ [ negate-cc ] change-cc ] when ;
+
 : fold-compare-imm ( insn -- insn' )
     dup evaluate-compare-imm >boolean-insn ;
 
@@ -165,3 +215,12 @@ M: ##compare-imm rewrite
         { [ dup fold-compare-imm? ] [ fold-compare-imm ] }
         [ drop f ]
     } cond ;
+
+: fold-compare-integer-imm ( insn -- insn' )
+    dup evaluate-compare-integer-imm >boolean-insn ;
+
+M: ##compare-integer-imm rewrite
+    {
+        { [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm ] }
+        [ drop f ]
+    } cond ;

basis/compiler/cfg/value-numbering/expressions/expressions.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors classes classes.algebra classes.parser
 classes.tuple combinators combinators.short-circuit fry
-generic.parser kernel layouts locals math namespaces quotations
+generic.parser kernel layouts math namespaces quotations
 sequences slots splitting words
 cpu.architecture
 compiler.cfg.instructions
@@ -57,18 +57,18 @@ M: integer-expr expr>integer value>> ;
 : vreg-immediate-arithmetic? ( vreg -- ? )
     vreg>expr {
         [ integer-expr? ]
-        [ expr>integer tag-fixnum immediate-arithmetic? ]
+        [ expr>integer immediate-arithmetic? ]
     } 1&& ;
 
 : vreg-immediate-bitwise? ( vreg -- ? )
     vreg>expr {
         [ integer-expr? ]
-        [ expr>integer tag-fixnum immediate-bitwise? ]
+        [ expr>integer immediate-bitwise? ]
     } 1&& ;
 
 GENERIC: expr>comparand ( expr -- n )
 
-M: integer-expr expr>comparand value>> ;
+M: integer-expr expr>comparand value>> tag-fixnum ;
 
 M: reference-expr expr>comparand value>> ;
 
@@ -94,18 +94,20 @@ M: reference-expr expr>comparand value>> ;
 : define-expr-class ( expr slot-specs -- )
     [ expr ] dip [ name>> ] map define-tuple-class ;
 
-: constant>vn ( obj -- vn )
+: constant-quot ( rep -- quot )
-    dup integer? [ <integer-expr> ] [ <reference-expr> ] if
+    {
-    expr>vn ;
+        { int-rep [ [ <integer-expr> ] ] }
+        { tagged-rep [ [ <reference-expr> ] ] }
+    } case [ expr>vn ] append ;
 
 : >expr-quot ( expr slot-specs -- quot )
      [
         [ name>> reader-word 1quotation ]
         [
-            type>> {
+            [ rep>> ] [ type>> ] bi {
-                { use [ [ vreg>vn ] ] }
+                { use [ drop [ vreg>vn ] ] }
-                { literal [ [ ] ] }
+                { literal [ drop [ ] ] }
-                { constant [ [ constant>vn ] ] }
+                { constant [ constant-quot ] }
             } case
         ] bi append
     ] map cleave>quot swap suffix \ boa suffix ;

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -13,6 +13,8 @@ IN: compiler.cfg.value-numbering.tests
         dup {
             [ ##compare? ]
             [ ##compare-imm? ]
+            [ ##compare-integer? ]
+            [ ##compare-integer-imm? ]
             [ ##compare-float-unordered? ]
             [ ##compare-float-ordered? ]
             [ ##test-vector? ]
@@ -72,17 +74,17 @@ IN: compiler.cfg.value-numbering.tests
 ! Double compare elimination
 [
     {
-        T{ ##load-reference f 1 "hi" }
+        T{ ##peek f 1 D 1 }
-        T{ ##peek f 2 D 0 }
+        T{ ##peek f 2 D 2 }
-        T{ ##compare f 4 2 1 cc> }
+        T{ ##compare f 4 2 1 cc= }
         T{ ##copy f 6 4 any-rep }
         T{ ##replace f 6 D 0 }
     }
 ] [
     {
-        T{ ##load-reference f 1 "hi" }
+        T{ ##peek f 1 D 1 }
-        T{ ##peek f 2 D 0 }
+        T{ ##peek f 2 D 2 }
-        T{ ##compare f 4 2 1 cc> }
+        T{ ##compare f 4 2 1 cc= }
         T{ ##compare-imm f 6 4 f cc/= }
         T{ ##replace f 6 D 0 }
     } value-numbering-step trim-temps
@@ -90,22 +92,72 @@ IN: compiler.cfg.value-numbering.tests
 
 [
     {
-        T{ ##load-reference f 1 "hi" }
+        T{ ##peek f 1 D 1 }
-        T{ ##peek f 2 D 0 }
+        T{ ##compare-imm f 2 1 16 cc= }
-        T{ ##compare f 4 2 1 cc<= }
+        T{ ##copy f 3 2 any-rep }
-        T{ ##compare f 6 2 1 cc/<= }
+        T{ ##replace f 3 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-imm f 2 1 16 cc= }
+        T{ ##compare-imm f 3 2 f cc/= }
+        T{ ##replace f 3 D 0 }
+    } value-numbering-step trim-temps
+] unit-test
+
+[
+    {
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##compare-integer f 4 2 1 cc> }
+        T{ ##copy f 6 4 any-rep }
         T{ ##replace f 6 D 0 }
     }
 ] [
     {
-        T{ ##load-reference f 1 "hi" }
+        T{ ##peek f 1 D 1 }
-        T{ ##peek f 2 D 0 }
+        T{ ##peek f 2 D 2 }
-        T{ ##compare f 4 2 1 cc<= }
+        T{ ##compare-integer f 4 2 1 cc> }
+        T{ ##compare-imm f 6 4 f cc/= }
+        T{ ##replace f 6 D 0 }
+    } value-numbering-step trim-temps
+] unit-test
+
+[
+    {
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##compare-integer f 4 2 1 cc<= }
+        T{ ##compare-integer f 6 2 1 cc/<= }
+        T{ ##replace f 6 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##compare-integer f 4 2 1 cc<= }
         T{ ##compare-imm f 6 4 f cc= }
         T{ ##replace f 6 D 0 }
     } value-numbering-step trim-temps
 ] unit-test
 
+[
+    {
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer-imm f 2 1 100 cc<= }
+        T{ ##compare-integer-imm f 3 1 100 cc/<= }
+        T{ ##replace f 3 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer-imm f 2 1 100 cc<= }
+        T{ ##compare-imm f 3 2 f cc= }
+        T{ ##replace f 3 D 0 }
+    } value-numbering-step trim-temps
+] unit-test
+
 [
     {
         T{ ##peek f 8 D 0 }
@@ -128,14 +180,30 @@ IN: compiler.cfg.value-numbering.tests
     {
         T{ ##peek f 29 D -1 }
         T{ ##peek f 30 D -2 }
-        T{ ##compare f 33 29 30 cc<= }
+        T{ ##compare f 33 29 30 cc= }
-        T{ ##compare-branch f 29 30 cc<= }
+        T{ ##compare-branch f 29 30 cc= }
     }
 ] [
     {
         T{ ##peek f 29 D -1 }
         T{ ##peek f 30 D -2 }
-        T{ ##compare f 33 29 30 cc<= }
+        T{ ##compare f 33 29 30 cc= }
+        T{ ##compare-imm-branch f 33 f cc/= }
+    } value-numbering-step trim-temps
+] unit-test
+
+[
+    {
+        T{ ##peek f 29 D -1 }
+        T{ ##peek f 30 D -2 }
+        T{ ##compare-integer f 33 29 30 cc<= }
+        T{ ##compare-integer-branch f 29 30 cc<= }
+    }
+] [
+    {
+        T{ ##peek f 29 D -1 }
+        T{ ##peek f 30 D -2 }
+        T{ ##compare-integer f 33 29 30 cc<= }
         T{ ##compare-imm-branch f 33 f cc/= }
     } value-numbering-step trim-temps
 ] unit-test
@@ -154,6 +222,22 @@ IN: compiler.cfg.value-numbering.tests
     } value-numbering-step trim-temps
 ] unit-test
 
+cpu x86.32? [
+    [
+        {
+            T{ ##peek f 1 D 0 }
+            T{ ##compare-imm f 2 1 + cc= }
+            T{ ##compare-imm-branch f 1 + cc= }
+        }
+    ] [
+        {
+            T{ ##peek f 1 D 0 }
+            T{ ##compare-imm f 2 1 + cc= }
+            T{ ##compare-imm-branch f 2 f cc/= }
+        } value-numbering-step trim-temps
+    ] unit-test
+] when
+
 ! Immediate operand fusion
 [
     {
@@ -409,13 +493,27 @@ IN: compiler.cfg.value-numbering.tests
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare-imm f 2 0 100 cc<= }
+        T{ ##compare-imm f 2 0 $[ 100 tag-fixnum ] cc= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare f 2 0 1 cc<= }
+        T{ ##compare f 2 0 1 cc= }
+    } value-numbering-step trim-temps
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-integer f 1 100 }
+        T{ ##compare-integer-imm f 2 0 100 cc<= }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-integer f 1 100 }
+        T{ ##compare-integer f 2 0 1 cc<= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -481,13 +579,13 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare-imm f 2 0 100 cc>= }
+        T{ ##compare-integer-imm f 2 0 100 cc>= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare f 2 1 0 cc<= }
+        T{ ##compare-integer f 2 1 0 cc<= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -495,13 +593,13 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare-imm-branch f 0 100 cc<= }
+        T{ ##compare-integer-imm-branch f 0 100 cc<= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare-branch f 0 1 cc<= }
+        T{ ##compare-integer-branch f 0 1 cc<= }
     } value-numbering-step
 ] unit-test
 
@@ -509,13 +607,13 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare-imm-branch f 0 100 cc>= }
+        T{ ##compare-integer-imm-branch f 0 100 cc>= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare-branch f 1 0 cc<= }
+        T{ ##compare-integer-branch f 1 0 cc<= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -530,7 +628,7 @@ cpu x86.32? [
     {
         T{ ##load-integer f 1 100 }
         T{ ##load-integer f 2 200 }
-        T{ ##compare f 3 1 2 cc<= }
+        T{ ##compare-integer f 3 1 2 cc<= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -544,7 +642,7 @@ cpu x86.32? [
     {
         T{ ##load-integer f 1 100 }
         T{ ##load-integer f 2 200 }
-        T{ ##compare f 3 1 2 cc= }
+        T{ ##compare-integer f 3 1 2 cc= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -556,90 +654,236 @@ cpu x86.32? [
 ] [
     {
         T{ ##load-integer f 1 100 }
-        T{ ##compare-imm f 2 1 f cc= }
+        T{ ##compare-integer-imm f 2 1 123 cc= }
     } value-numbering-step trim-temps
 ] unit-test
 
 [
     {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-integer f 2 20 }
+        T{ ##load-reference f 3 f }
+    }
+] [
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-integer f 2 20 }
+        T{ ##compare-integer f 3 1 2 cc= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
+        T{ ##load-reference f 3 t }
+    }
+] [
+    {
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
+        T{ ##compare-integer f 3 1 2 cc/= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
+        T{ ##load-reference f 3 t }
+    }
+] [
+    {
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
+        T{ ##compare-integer f 3 1 2 cc< }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-integer f 2 20 }
+        T{ ##load-reference f 3 f }
+    }
+] [
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-integer f 2 20 }
+        T{ ##compare-integer f 3 2 1 cc< }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
         T{ ##load-reference f 1 f }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare-integer f 1 0 0 cc< }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 t }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare-integer f 1 0 0 cc<= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 f }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare-integer f 1 0 0 cc> }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 t }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare-integer f 1 0 0 cc>= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 f }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare-integer f 1 0 0 cc/= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 t }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare-integer f 1 0 0 cc= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-reference f 2 f }
+    }
+] [
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##compare-imm f 2 1 10 cc= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 10 }
         T{ ##load-reference f 2 t }
     }
 ] [
-    {
-        T{ ##load-reference f 1 f }
-        T{ ##compare-imm f 2 1 f cc= }
-    } value-numbering-step trim-temps
-] unit-test
-
-[
     {
         T{ ##load-integer f 1 10 }
-        T{ ##load-integer f 2 20 }
+        T{ ##compare-imm f 2 1 $[ 10 tag-fixnum ] cc= }
-        T{ ##load-reference f 3 f }
-    }
-] [
-    {
-        T{ ##load-integer f 1 10 }
-        T{ ##load-integer f 2 20 }
-        T{ ##compare f 3 1 2 cc= }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##load-integer f 1 1 }
-        T{ ##load-integer f 2 2 }
-        T{ ##load-reference f 3 t }
-    }
-] [
-    {
-        T{ ##load-integer f 1 1 }
-        T{ ##load-integer f 2 2 }
-        T{ ##compare f 3 1 2 cc/= }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##load-integer f 1 1 }
-        T{ ##load-integer f 2 2 }
-        T{ ##load-reference f 3 t }
-    }
-] [
-    {
-        T{ ##load-integer f 1 1 }
-        T{ ##load-integer f 2 2 }
-        T{ ##compare f 3 1 2 cc< }
     } value-numbering-step
 ] unit-test
 
 [
     {
         T{ ##load-integer f 1 10 }
-        T{ ##load-integer f 2 20 }
+        T{ ##load-reference f 2 t }
-        T{ ##load-reference f 3 f }
     }
 ] [
     {
         T{ ##load-integer f 1 10 }
-        T{ ##load-integer f 2 20 }
+        T{ ##compare-imm f 2 1 10 cc/= }
-        T{ ##compare f 3 2 1 cc< }
     } value-numbering-step
 ] unit-test
 
 [
     {
-        T{ ##peek f 0 D 0 }
+        T{ ##load-integer f 1 10 }
-        T{ ##load-reference f 1 f }
+        T{ ##load-reference f 2 f }
     }
 ] [
     {
-        T{ ##peek f 0 D 0 }
+        T{ ##load-integer f 1 10 }
-        T{ ##compare f 1 0 0 cc< }
+        T{ ##compare-imm f 2 1 $[ 10 tag-fixnum ] cc/= }
     } value-numbering-step
 ] unit-test
 
+cpu x86.32? [
+    [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##load-reference f 2 f }
+        }
+    ] [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##compare-imm f 2 1 + cc/= }
+        } value-numbering-step
+    ] unit-test
+
+    [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##load-reference f 2 t }
+        }
+    ] [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##compare-imm f 2 1 * cc/= }
+        } value-numbering-step
+    ] unit-test
+
+    [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##load-reference f 2 t }
+        }
+    ] [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##compare-imm f 2 1 + cc= }
+        } value-numbering-step
+    ] unit-test
+
+    [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##load-reference f 2 f }
+        }
+    ] [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##compare-imm f 2 1 * cc= }
+        } value-numbering-step
+    ] unit-test
+] when
+
 [
     {
         T{ ##peek f 0 D 0 }
@@ -648,31 +892,7 @@ cpu x86.32? [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc<= }
+        T{ ##compare f 1 0 0 cc= }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 f }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc> }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 t }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc>= }
     } value-numbering-step
 ] unit-test
 
@@ -688,18 +908,6 @@ cpu x86.32? [
     } value-numbering-step
 ] unit-test
 
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 t }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc= }
-    } value-numbering-step
-] unit-test
-
 ! Reassociation
 [
     {
@@ -1560,7 +1768,7 @@ cell 8 = [
     {
         T{ ##load-integer f 1 1 }
         T{ ##load-integer f 2 2 }
-        T{ ##compare-branch f 1 2 cc< }
+        T{ ##compare-integer-branch f 1 2 cc< }
     } test-branch-folding
 ] unit-test
 
@@ -1575,7 +1783,7 @@ cell 8 = [
     {
         T{ ##load-integer f 1 1 }
         T{ ##load-integer f 2 2 }
-        T{ ##compare-branch f 2 1 cc< }
+        T{ ##compare-integer-branch f 2 1 cc< }
     } test-branch-folding
 ] unit-test
 
@@ -1588,7 +1796,7 @@ cell 8 = [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare-branch f 0 0 cc< }
+        T{ ##compare-integer-branch f 0 0 cc< }
     } test-branch-folding
 ] unit-test
 
@@ -1601,7 +1809,7 @@ cell 8 = [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare-branch f 0 0 cc<= }
+        T{ ##compare-integer-branch f 0 0 cc<= }
     } test-branch-folding
 ] unit-test
 
@@ -1614,7 +1822,7 @@ cell 8 = [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare-branch f 0 0 cc> }
+        T{ ##compare-integer-branch f 0 0 cc> }
     } test-branch-folding
 ] unit-test
 
@@ -1627,7 +1835,7 @@ cell 8 = [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare-branch f 0 0 cc>= }
+        T{ ##compare-integer-branch f 0 0 cc>= }
     } test-branch-folding
 ] unit-test
 
@@ -1640,7 +1848,7 @@ cell 8 = [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare-branch f 0 0 cc= }
+        T{ ##compare-integer-branch f 0 0 cc= }
     } test-branch-folding
 ] unit-test
 
@@ -1653,7 +1861,7 @@ cell 8 = [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare-branch f 0 0 cc/= }
+        T{ ##compare-integer-branch f 0 0 cc/= }
     } test-branch-folding
 ] unit-test
 
@@ -1677,7 +1885,7 @@ V{ T{ ##branch } } 0 test-bb
 
 V{
     T{ ##peek f 0 D 0 }
-    T{ ##compare-branch f 0 0 cc< }
+    T{ ##compare-integer-branch f 0 0 cc< }
 } 1 test-bb
 
 V{
@@ -1718,7 +1926,7 @@ V{
 
 V{
     T{ ##peek f 1 D 1 }
-    T{ ##compare-branch f 1 1 cc< }
+    T{ ##compare-integer-branch f 1 1 cc< }
 } 1 test-bb
 
 V{
@@ -1816,4 +2024,3 @@ V{
 ] unit-test
 
 [ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
-

basis/compiler/codegen/codegen.factor

@@ -119,7 +119,7 @@ CODEGEN: ##not %not
 CODEGEN: ##neg %neg
 CODEGEN: ##log2 %log2
 CODEGEN: ##copy %copy
-CODEGEN: ##tagged>integer %copy
+CODEGEN: ##tagged>integer %tagged>integer
 CODEGEN: ##add-float %add-float
 CODEGEN: ##sub-float %sub-float
 CODEGEN: ##mul-float %mul-float
@@ -210,6 +210,8 @@ CODEGEN: ##write-barrier %write-barrier
 CODEGEN: ##write-barrier-imm %write-barrier-imm
 CODEGEN: ##compare %compare
 CODEGEN: ##compare-imm %compare-imm
+CODEGEN: ##compare-integer %compare
+CODEGEN: ##compare-integer-imm %compare-imm
 CODEGEN: ##compare-float-ordered %compare-float-ordered
 CODEGEN: ##compare-float-unordered %compare-float-unordered
 CODEGEN: ##save-context %save-context

basis/cpu/architecture/architecture.factor

@@ -253,6 +253,8 @@ HOOK: %log2    cpu ( dst src -- )
 
 HOOK: %copy cpu ( dst src rep -- )
 
+: %tagged>integer ( dst src -- ) int-rep %copy ;
+
 HOOK: %fixnum-add cpu ( label dst src1 src2 -- )
 HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
 HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )