removed fixnum<< vop since it was buggy and afforded no performance gain, and also simplified some code

library/collections/namespaces.factor

@@ -23,15 +23,16 @@ sequences strings vectors words ;
 : change ( var quot -- quot: old -- new )
     >r dup get r> rot slip set ; inline
 
-: inc ( var -- ) [ 1+ ] change ; inline
+: +@ ( n var -- ) [ [ 0 ] unless* + ] change ;
 
-: counter ( var -- n )
+: inc ( var -- ) 1 swap +@ ; inline
-    global [ [ [ 0 ] unless* dup 1+ >fixnum ] change ] bind ;
 
-: dec ( var -- ) [ 1- ] change ; inline
+: dec ( var -- ) -1 swap +@ ; inline
 
 : bind ( namespace quot -- ) swap >n call n> drop ; inline
 
+: counter ( var -- n ) global [ dup inc get ] bind ;
+
 : make-hash ( quot -- hash ) H{ } clone >n call n> ; inline
 
 : with-scope ( quot -- ) make-hash drop ; inline

library/compiler/intrinsics.factor

@@ -22,8 +22,8 @@ namespaces sequences words ;
 
 : slot@ ( node -- n/f )
     #! Compute slot offset.
-    dup node-in-d reverse-slice dup first dup literal? [
+    dup node-in-d reverse-slice dup first dup value? [
-        literal-value cells swap second
+        value-literal cells swap second
         rot value-tag dup [ - ] [ 2drop f ] if
     ] [
         3drop f
@@ -90,7 +90,7 @@ namespaces sequences words ;
 
 \ getenv [
     -1 %inc-d ,
-    node-peek literal-value 0 <vreg> swap %getenv ,
+    node-peek value-literal 0 <vreg> swap %getenv ,
     1 %inc-d ,
     out-1
 ] "intrinsic" set-word-prop
@@ -98,7 +98,7 @@ namespaces sequences words ;
 \ setenv [
     -1 %inc-d ,
     in-1
-    node-peek literal-value 0 <vreg> swap %setenv ,
+    node-peek value-literal 0 <vreg> swap %setenv ,
     -1 %inc-d ,
 ] "intrinsic" set-word-prop
 
@@ -118,13 +118,13 @@ namespaces sequences words ;
     >r binary-inputs dup -1 %inc-d , r> execute , out-1 ; inline
 
 : binary-imm ( node -- in1 in2 )
-    -1 %inc-d , in-1 node-peek literal-value 0 <vreg> ;
+    -1 %inc-d , in-1 node-peek value-literal 0 <vreg> ;
 
 : binary-op-imm ( node op -- )
     >r binary-imm dup r> execute , out-1 ; inline
 
 : literal-immediate? ( value -- ? )
-    dup literal? [ literal-value immediate? ] [ drop f ] if ;
+    dup value? [ value-literal immediate? ] [ drop f ] if ;
 
 : binary-op-imm? ( node -- ? )
     fixnum-imm? >r node-peek literal-immediate? r> and ;
@@ -197,25 +197,8 @@ namespaces sequences words ;
     out-1
 ] "intrinsic" set-word-prop
 
-: fast-fixnum* ( n -- )
-    -1 %inc-d ,
-    in-1
-    log2 0 <vreg> 0 <vreg> %fixnum<< ,
-    out-1 ;
-
-: slow-fixnum* ( node -- ) \ %fixnum* binary-op-reg ;
-
 \ fixnum* [
-    ! Turn multiplication by a power of two into a left shift.
+    \ %fixnum* binary-op-reg
-    dup node-peek dup literal-immediate? [
-        literal-value dup power-of-2? [
-            nip fast-fixnum*
-        ] [
-            drop slow-fixnum*
-        ] if
-    ] [
-        drop slow-fixnum*
-    ] if
 ] "intrinsic" set-word-prop
 
 : slow-shift ( -- ) \ fixnum-shift %call , ;
@@ -231,16 +214,6 @@ namespaces sequences words ;
         out-1
     ] if ;
 
-: positive-shift ( n -- )
-    dup cell-bits tag-bits - <= [
-        -1 %inc-d ,
-        in-1
-        0 <vreg> 0 <vreg> %fixnum<< ,
-        out-1
-    ] [
-        drop slow-shift
-    ] if ;
-
 : fast-shift ( n -- )
     dup 0 = [
         -1 %inc-d ,
@@ -249,13 +222,13 @@ namespaces sequences words ;
         dup 0 < [
             negative-shift
         ] [
-            positive-shift
+            drop slow-shift
         ] if
     ] if ;
 
 \ fixnum-shift [
-    node-peek dup literal? [
+    node-peek dup value? [
-        literal-value fast-shift
+        value-literal fast-shift
     ] [
         drop slow-shift
     ] if

library/compiler/ppc/fixnum.factor

@@ -111,31 +111,6 @@ M: %fixnum-bitnot generate-node ( vop -- )
     drop dest/src NOT
     0 output-operand dup untag ;
 
-M: %fixnum<< generate-node ( vop -- )
-    ! This has specific register requirements.
-    drop
-    <label> "no-overflow" set
-    <label> "end" set
-    ! check for potential overflow
-    0 input shift-add dup 1 scratch LOAD
-    0 scratch 1 input-operand 1 scratch ADD
-    2 * 1- 1 scratch LOAD
-    1 scratch 0 0 scratch CMPL
-    ! is there going to be an overflow?
-    "no-overflow" get BGE
-    ! there is going to be an overflow, make a bignum
-    1 input-operand dup untag-fixnum
-    "s48_long_to_bignum" f compile-c-call
-    0 input 0 scratch LI
-    "s48_bignum_arithmetic_shift" f compile-c-call
-    ! tag the result
-    1 input-operand dup bignum-tag ORI
-    "end" get B
-    ! there is not going to be an overflow
-    "no-overflow" get save-xt
-    1 input-operand dup 0 input SLWI.
-    "end" get save-xt ;
-
 M: %fixnum>> generate-node ( vop -- )
     drop
     1 input-operand 0 output-operand 0 input SRAWI

library/compiler/stack.factor

@@ -18,15 +18,15 @@ M: object load-value ( vreg n value -- )
 : load-literal ( vreg obj -- )
     dup immediate? [ %immediate ] [ %indirect ] if , ;
 
-M: literal load-value ( vreg n value -- )
+M: value load-value ( vreg n value -- )
-    nip literal-value load-literal ;
+    nip value-literal load-literal ;
 
 SYMBOL: vreg-allocator
 SYMBOL: live-d
 SYMBOL: live-r
 
 : value-dropped? ( value -- ? )
-    dup literal?
+    dup value?
     over live-d get member? not
     rot live-r get member? not and
     or ;
@@ -50,7 +50,7 @@ SYMBOL: live-r
     dup node-out-r length swap node-in-r length - %inc-r , ;
 
 : literal>stack ( stack-pos value storer -- )
-    >r literal-value r> fixnum-imm? pick immediate? and [
+    >r value-literal r> fixnum-imm? pick immediate? and [
         >r 0 swap load-literal 0 <vreg> r>
     ] unless swapd execute , ; inline
 
@@ -59,7 +59,7 @@ SYMBOL: live-r
 : vreg>stack ( stack-pos value storer -- )
     {
         { [ over not ] [ 3drop ] }
-        { [ over literal? ] [ literal>stack ] }
+        { [ over value? ] [ literal>stack ] }
         { [ t ] [ computed>stack ] }
     } cond ; inline
 
@@ -71,8 +71,8 @@ SYMBOL: live-r
     \ %replace-r (vregs>stack) \ %replace-d (vregs>stack) ;
 
 : literals/computed ( stack -- literals computed )
-    dup [ dup literal? [ drop f ] unless ] map
+    dup [ dup value? [ drop f ] unless ] map
-    swap [ dup literal? [ drop f ] when ] map ;
+    swap [ dup value? [ drop f ] when ] map ;
 
 : vregs>stacks ( -- )
     live-d get literals/computed

library/compiler/vops.factor

@@ -281,17 +281,13 @@ TUPLE: %fixnum-bitnot ;
 C: %fixnum-bitnot make-vop ; : %fixnum-bitnot 2-vop <%fixnum-bitnot> ;
 M: %fixnum-bitnot basic-block? drop t ;
 
-! At the VOP level, the 'shift' operation is split into five
+! At the VOP level, the 'shift' operation is split into four
 ! distinct operations:
-! - shifts with a large positive count: calls runtime to make
+! - shifts with a positive count: calls runtime to make
 !   a bignum
-! - shifts with a small positive count: %fixnum<<
 ! - shifts with a small negative count: %fixnum>>
 ! - shifts with a small negative count: %fixnum>>
 ! - shifts with a large negative count: %fixnum-sgn
-TUPLE: %fixnum<< ;
-C: %fixnum<< make-vop ;   : %fixnum<<   3-vop <%fixnum<<> ;
-
 TUPLE: %fixnum>> ;
 C: %fixnum>> make-vop ;   : %fixnum>>   3-vop <%fixnum>>> ;
 M: %fixnum>> basic-block? drop t ;

library/compiler/x86/fixnum.factor

@@ -103,31 +103,6 @@ M: %fixnum-bitnot generate-node ( vop -- )
     ! Mask off the low 3 bits to give a fixnum tag
     0 output-operand tag-mask XOR ;
 
-M: %fixnum<< generate-node
-    #! This has specific register requirements.
-    drop
-    <label> "no-overflow" set
-    <label> "end" set
-    ! make a copy
-    0 scratch 1 input-operand MOV
-    ! check for potential overflow
-    0 scratch 0 input shift-add 2dup ADD 2 * 1- CMP
-    ! is there going to be an overflow?
-    "no-overflow" get JBE
-    ! there is going to be an overflow, make a bignum
-    1 input-operand tag-bits SAR
-    "s48_long_to_bignum" f
-    1 input-operand 1array compile-c-call*
-    "s48_bignum_arithmetic_shift" f
-    1 input-operand 0 input 2array compile-c-call*
-    ! tag the result
-    1 input-operand bignum-tag OR
-    "end" get JMP
-    ! there is not going to be an overflow
-    "no-overflow" get save-xt
-    1 input-operand 0 input SHL
-    "end" get save-xt ;
-
 M: %fixnum>> generate-node
     drop
     ! shift register

library/inference/branches.factor

@@ -12,7 +12,7 @@ namespaces parser prettyprint sequences strings vectors words ;
 : unify-values ( seq -- value )
     #! If all values in list are equal, return the value.
     #! Otherwise, unify.
-    dup all-eq? [ first ] [ drop <value> ] if ;
+    dup all-eq? [ first ] [ drop <computed> ] if ;
 
 : unify-stacks ( seq -- stack )
     #! Replace differing literals in stacks with unknown
@@ -81,7 +81,7 @@ namespaces parser prettyprint sequences strings vectors words ;
             base-case-continuation set
             copy-inference
             dup value-recursion recursive-state set
-            dup literal-value infer-quot
+            dup value-literal infer-quot
             terminated? get [ #values node, ] unless
             f
         ] callcc1 [ terminate ] when drop

library/inference/call-optimizers.factor

@@ -18,7 +18,7 @@ math math-internals sequences words ;
 : partial-eval? ( #call -- ? )
     dup node-param "foldable" word-prop [
         dup node-in-d [
-            dup literal?
+            dup value?
             [ 2drop t ] [ swap node-literals ?hash* nip ] if
         ] all-with?
     ] [
@@ -27,8 +27,8 @@ math math-internals sequences words ;
 
 : literal-in-d ( #call -- inputs )
     dup node-in-d [
-        dup literal?
+        dup value?
-        [ nip literal-value ] [ swap node-literals ?hash ] if
+        [ nip value-literal ] [ swap node-literals ?hash ] if
     ] map-with ;
 
 : partial-eval ( #call -- node )
@@ -70,7 +70,7 @@ SYMBOL: @
 
 : literals-match? ( values template -- ? )
     [
-        over literal? [ >r literal-value r> ] [ nip @ ] if =
+        over value? [ >r value-literal r> ] [ nip @ ] if =
     ] 2map [ ] all? ;
 
 : values-match? ( values template -- ? )

library/inference/class-infer.factor

@@ -23,24 +23,24 @@ M: f apply-tie ( f -- ) drop ;
 
 TUPLE: class-tie value class ;
 
-: set-value-class ( class value -- )
+: annotate-value-class ( class value -- )
     2dup swap <class-tie> ties get hash [ apply-tie ] when*
     value-classes get set-hash ;
 
 M: class-tie apply-tie ( tie -- )
     dup class-tie-class swap class-tie-value
-    set-value-class ;
+    annotate-value-class ;
 
 TUPLE: literal-tie value literal ;
 
-: set-value-literal ( literal value -- )
+: annotate-value-literal ( literal value -- )
-    over class over set-value-class
+    over class over annotate-value-class
     2dup swap <literal-tie> ties get hash [ apply-tie ] when*
     value-literals get set-hash ;
 
 M: literal-tie apply-tie ( tie -- )
     dup literal-tie-literal swap literal-tie-value
-    set-value-literal ;
+    annotate-value-literal ;
 
 GENERIC: infer-classes* ( node -- )
 
@@ -65,7 +65,9 @@ M: node child-ties ( node -- seq )
     [ dup value-class ] map>hash swap set-node-classes ;
 
 : intersect-classes ( classes values -- )
-    [ [ value-class class-and ] keep set-value-class ] 2each ;
+    [
+        [ value-class class-and ] keep annotate-value-class
+    ] 2each ;
 
 : type/tag-ties ( node n -- )
     over node-out-d first over [ <literal-tie> ] map-with
@@ -77,8 +79,8 @@ M: node child-ties ( node -- seq )
 \ tag [ num-tags type/tag-ties ] "create-ties" set-word-prop
 
 \ eq? [
-    dup node-in-d second literal? [
+    dup node-in-d second value? [
-        dup node-in-d first2 literal-value <literal-tie>
+        dup node-in-d first2 value-literal <literal-tie>
         over node-out-d first general-t <class-tie>
         ties get set-hash
     ] when drop
@@ -100,7 +102,7 @@ M: node child-ties ( node -- seq )
     ] if ;
 
 \ make-tuple [
-    dup node-in-d first literal-value 1array
+    dup node-in-d first value-literal 1array
 ] "output-classes" set-word-prop
 
 : output-classes ( node -- seq )
@@ -119,8 +121,8 @@ M: #call infer-classes* ( node -- )
     ] when drop ;
 
 M: #shuffle infer-classes* ( node -- )
-    node-out-d [ literal? ] subset
+    node-out-d [ value? ] subset
-    [ [ literal-value ] keep set-value-literal ] each ;
+    [ [ value-literal ] keep annotate-value-literal ] each ;
 
 M: #if child-ties ( node -- seq )
     node-in-d first dup general-t <class-tie>

library/inference/dataflow.factor

@@ -7,23 +7,22 @@ namespaces parser sequences words ;
 ! Recursive state. An alist, mapping words to labels.
 SYMBOL: recursive-state
 
-TUPLE: value recursion uid ;
+: <computed> \ <computed> counter ;
 
-C: value ( -- value )
+TUPLE: value uid literal recursion ;
-    \ value counter over set-value-uid
-    recursive-state get over set-value-recursion ;
 
-M: value = eq? ;
+C: value ( obj -- value )
+    <computed> over set-value-uid
+    recursive-state get over set-value-recursion
+    [ set-value-literal ] keep ;
 
 M: value hashcode value-uid ;
 
-TUPLE: literal value ;
+M: value = eq? ;
 
-C: literal ( obj -- value )
+M: integer value-uid ;
-    <value> over set-delegate
-    [ set-literal-value ] keep ;
 
-M: literal hashcode delegate hashcode ;
+M: integer value-recursion drop f ;
 
 ! The dataflow IR is the first of the two intermediate
 ! representations used by Factor. It annotates concatenative

library/inference/inference.factor

@@ -24,7 +24,7 @@ M: inference-error error. ( error -- )
     "Recursive state:" print
     inference-error-rstate describe ;
 
-M: value literal-value ( value -- )
+M: integer value-literal ( value -- )
     {
         "A literal value was expected where a computed value was found.\n"
         "This means the word you are inferring applies 'call' or 'execute'\n"
@@ -43,9 +43,10 @@ M: value literal-value ( value -- )
 SYMBOL: d-in
 
 : pop-literal ( -- rstate obj )
-    1 #drop node, pop-d dup value-recursion swap literal-value ;
+    1 #drop node,
+    pop-d dup value-recursion swap value-literal ;
 
-: value-vector ( n -- vector ) [ drop <value> ] map >vector ;
+: value-vector ( n -- vector ) [ drop <computed> ] map >vector ;
 
 : required-inputs ( n stack -- n ) length - 0 max ;
 
@@ -77,7 +78,7 @@ GENERIC: apply-object
 : apply-literal ( obj -- )
     #! Literals are annotated with the current recursive
     #! state.
-    <literal> push-d  1 #push node, ;
+    <value> push-d  1 #push node, ;
 
 M: object apply-object apply-literal ;
 

library/inference/kill-literals.factor

@@ -53,7 +53,7 @@ M: node returns* ( node -- seq ) node-successor returns* ;
 ! #shuffle
 M: #shuffle literals* ( node -- seq )
     dup node-out-d swap node-out-r
-    [ [ literal? ] subset ] 2apply append ;
+    [ [ value? ] subset ] 2apply append ;
 
 ! #return
 M: #return returns* , ;

library/inference/known-words.factor

@@ -66,7 +66,7 @@ sequences strings vectors words prettyprint ;
 \ dispatch [ [ fixnum array ] [ ] ] "infer-effect" set-word-prop
 
 \ dispatch [
-    pop-literal nip [ <literal> ] map
+    pop-literal nip [ <value> ] map
     #dispatch pop-d drop infer-branches
 ] "infer" set-word-prop
 

library/inference/optimizer.factor

@@ -73,7 +73,7 @@ M: #shuffle optimize-node*  ( node -- node/t )
 
 ! #if
 : static-branch? ( node -- lit ? )
-    node-in-d first dup literal? ;
+    node-in-d first dup value? ;
 
 : static-branch ( conditional n -- node )
     over drop-inputs
@@ -81,7 +81,7 @@ M: #shuffle optimize-node*  ( node -- node/t )
 
 M: #if optimize-node* ( node -- node )
     dup static-branch?
-    [ literal-value 0 1 ? static-branch ] [ 2drop t ] if ;
+    [ value-literal 0 1 ? static-branch ] [ 2drop t ] if ;
 
 ! #values
 : optimize-fold ( node -- node/t )

library/inference/print-dataflow.factor

@@ -19,10 +19,10 @@ M: comment pprint* ( ann -- )
 : values% ( prefix values -- )
     [
         swap %
-        dup literal? [
+        dup value? [
-            literal-value unparse %
+            value-literal unparse %
         ] [
-            "@" % value-uid #
+            "@" % #
         ] if
     ] each-with ;
 

library/inference/words.factor

@@ -10,7 +10,7 @@ strings vectors words ;
     over 0 rot node-inputs [ pop-d 2drop ] each ;
 
 : produce-values ( n node -- )
-    over [ drop <value> push-d ] each 0 swap node-outputs ;
+    over [ drop <computed> push-d ] each 0 swap node-outputs ;
 
 : consume/produce ( word effect -- )
     #! Add a node to the dataflow graph that consumes and

library/test/compiler/optimizer.factor

@@ -40,7 +40,7 @@ IN: temporary
 
 : kill-set=
     dataflow dup split-node
-    kill-set hash-keys [ literal-value ] map set= ;
+    kill-set hash-keys [ value-literal ] map set= ;
 
 : foo 1 2 3 ;
 
@@ -106,7 +106,7 @@ IN: temporary
 
 [ t ] [
     [ [ ] swap literal-kill-test-8 ] dataflow
-    dup split-node live-values hash-values [ literal? ] subset empty?
+    dup split-node live-values hash-values [ value? ] subset empty?
 ] unit-test
 
 ! Test method inlining

library/tools/annotations.factor

@@ -30,8 +30,6 @@ sequences strings walker ;
     #! Cause the word to start the code walker when executed.
     [ nip [ walk ] cons ] annotate ;
 
-: +@ ( n var -- ) dup get [ swap >r + r> ] when* set ;
-
 : with-profile ( quot word -- )
     millis >r >r call r> millis r> - swap global [ +@ ] bind ;
     inline