: 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 )
- global [ [ [ 0 ] unless* dup 1+ >fixnum ] change ] bind ;
+: inc ( var -- ) 1 swap +@ ; inline
-: 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
: slot@ ( node -- n/f )
#! Compute slot offset.
- dup node-in-d reverse-slice dup first dup literal? [
- literal-value cells swap second
+ dup node-in-d reverse-slice dup first dup value? [
+ value-literal cells swap second
rot value-tag dup [ - ] [ 2drop f ] if
] [
3drop f
\ 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
\ 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
>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 ;
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.
- dup node-peek dup literal-immediate? [
- literal-value dup power-of-2? [
- nip fast-fixnum*
- ] [
- drop slow-fixnum*
- ] if
- ] [
- drop slow-fixnum*
- ] if
+ \ %fixnum* binary-op-reg
] "intrinsic" set-word-prop
: slow-shift ( -- ) \ fixnum-shift %call , ;
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 ,
dup 0 < [
negative-shift
] [
- positive-shift
+ drop slow-shift
] if
] if ;
\ fixnum-shift [
- node-peek dup literal? [
- literal-value fast-shift
+ node-peek dup value? [
+ value-literal fast-shift
] [
drop slow-shift
] if
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
: load-literal ( vreg obj -- )
dup immediate? [ %immediate ] [ %indirect ] if , ;
-M: literal load-value ( vreg n value -- )
- nip literal-value load-literal ;
+M: value load-value ( vreg n value -- )
+ 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 ;
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
: vreg>stack ( stack-pos value storer -- )
{
{ [ over not ] [ 3drop ] }
- { [ over literal? ] [ literal>stack ] }
+ { [ over value? ] [ literal>stack ] }
{ [ t ] [ computed>stack ] }
} cond ; inline
\ %replace-r (vregs>stack) \ %replace-d (vregs>stack) ;
: literals/computed ( stack -- literals computed )
- dup [ dup literal? [ drop f ] unless ] map
- swap [ dup literal? [ drop f ] when ] map ;
+ dup [ dup value? [ drop f ] unless ] map
+ swap [ dup value? [ drop f ] when ] map ;
: vregs>stacks ( -- )
live-d get literals/computed
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 ;
! 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
: 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
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
: 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?
] [
: literal-in-d ( #call -- inputs )
dup node-in-d [
- dup literal?
- [ nip literal-value ] [ swap node-literals ?hash ] if
+ dup value?
+ [ nip value-literal ] [ swap node-literals ?hash ] if
] map-with ;
: partial-eval ( #call -- node )
: 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 -- ? )
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 -- )
- over class over set-value-class
+: annotate-value-literal ( literal value -- )
+ 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 -- )
[ 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
\ tag [ num-tags type/tag-ties ] "create-ties" set-word-prop
\ eq? [
- dup node-in-d second literal? [
- dup node-in-d first2 literal-value <literal-tie>
+ dup node-in-d second value? [
+ dup node-in-d first2 value-literal <literal-tie>
over node-out-d first general-t <class-tie>
ties get set-hash
] when drop
] 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 )
] when drop ;
M: #shuffle infer-classes* ( node -- )
- node-out-d [ literal? ] subset
- [ [ literal-value ] keep set-value-literal ] each ;
+ node-out-d [ value? ] subset
+ [ [ value-literal ] keep annotate-value-literal ] each ;
M: #if child-ties ( node -- seq )
node-in-d first dup general-t <class-tie>
! Recursive state. An alist, mapping words to labels.
SYMBOL: recursive-state
-TUPLE: value recursion uid ;
+: <computed> \ <computed> counter ;
-C: value ( -- value )
- \ value counter over set-value-uid
- recursive-state get over set-value-recursion ;
+TUPLE: value uid literal 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 )
- <value> over set-delegate
- [ set-literal-value ] keep ;
+M: integer value-uid ;
-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
"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"
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 ;
: 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 ;
! #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* , ;
\ 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
! #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
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 )
: values% ( prefix values -- )
[
swap %
- dup literal? [
- literal-value unparse %
+ dup value? [
+ value-literal unparse %
] [
- "@" % value-uid #
+ "@" % #
] if
] each-with ;
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
: 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 ;
[ 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
#! 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
projects / factor.git / commitdiff