M: #phi propagate*
#! If any of the outputs of a #phi are live, then the
#! corresponding inputs are live too.
- [ [ out-d>> ] [ phi-in-d>> flip ] bi look-at-corresponding ]
- [ [ out-r>> ] [ phi-in-r>> flip ] bi look-at-corresponding ]
+ [ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
+ [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
2bi ;
M: node propagate* 2drop ;
: remove-dead-phi-d ( #phi -- #phi )
dup
- [ phi-in-d>> flip ] [ out-d>> ] bi
+ [ phi-in-d>> ] [ out-d>> ] bi
filter-corresponding-values
- [ flip >>phi-in-d ] [ >>out-d ] bi* ;
+ [ >>phi-in-d ] [ >>out-d ] bi* ;
: remove-dead-phi-r ( #phi -- #phi )
dup
- [ phi-in-r>> flip ] [ out-r>> ] bi
+ [ phi-in-r>> ] [ out-r>> ] bi
filter-corresponding-values
- [ flip >>phi-in-r ] [ >>out-r ] bi* ;
+ [ >>phi-in-r ] [ >>out-r ] bi* ;
M: #phi remove-dead-values*
remove-dead-phi-d
GENERIC: node-uses-values ( node -- values )
M: #phi node-uses-values
- [ phi-in-d>> concat ] [ phi-in-r>> concat ] bi append ;
+ [ phi-in-d>> concat ] [ phi-in-r>> concat ] bi
+ append sift prune ;
M: #r> node-uses-values in-r>> ;
M: node node-defs-values out-d>> ;
-: each-value ( node values quot -- )
- [ sift ] dip with each ; inline
-
: node-def-use ( node -- )
- [ dup node-uses-values [ use-value ] each-value ]
- [ dup node-defs-values [ def-value ] each-value ] bi ;
+ [ dup node-uses-values [ use-value ] with each ]
+ [ dup node-defs-values [ def-value ] with each ] bi ;
: check-def-use ( -- )
def-use get [
USING: fry kernel sequences assocs accessors namespaces
math.intervals arrays classes.algebra
compiler.tree
+compiler.tree.def-use
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
compiler.tree.propagation.simple
compiler.tree.propagation.constraints ;
IN: compiler.tree.propagation.branches
GENERIC: child-constraints ( node -- seq )
M: #if child-constraints
- [
- \ f class-not 0 `input class,
- f 0 `input literal,
- ] make-constraints ;
+ in-d>> first
+ [ <true-constraint> ] [ <false-constraint> ] bi
+ 2array ;
-M: #dispatch child-constraints
- dup [
- children>> length [ 0 `input literal, ] each
- ] make-constraints ;
-
-DEFER: (propagate)
+M: #dispatch child-constraints drop f ;
: infer-children ( node -- assocs )
[ children>> ] [ child-constraints ] bi [
[
- value-classes [ clone ] change
- value-literals [ clone ] change
- value-intervals [ clone ] change
+ value-infos [ clone ] change
constraints [ clone ] change
- apply-constraint
+ assume
(propagate)
] H{ } make-assoc
] 2map ;
-: merge-classes ( inputs outputs results -- )
- '[
- , null
- [ [ value-class ] bind class-or ] 2reduce
- _ set-value-class
- ] 2each ;
-
-: merge-intervals ( inputs outputs results -- )
- '[
- , [ [ value-interval ] bind ] 2map
- dup first [ interval-union ] reduce
- _ set-value-interval
- ] 2each ;
+: (merge-value-infos) ( inputs results -- infos )
+ '[ , [ [ value-info ] bind ] 2map value-infos-union ] map ;
-: merge-literals ( inputs outputs results -- )
- '[
- , [ [ value-literal 2array ] bind ] 2map
- dup all-eq? [ first first2 ] [ drop f f ] if
- _ swap [ set-value-literal ] [ 2drop ] if
- ] 2each ;
+: merge-value-infos ( results inputs outputs -- )
+ [ swap (merge-value-infos) ] dip set-value-infos ;
-: merge-stuff ( inputs outputs results -- )
- [ merge-classes ] [ merge-intervals ] [ merge-literals ] 3tri ;
+: propagate-branch-phi ( results #phi -- )
+ [ nip node-defs-values [ introduce-value ] each ]
+ [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
+ [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
+ 2tri ;
: merge-children ( results node -- )
- successor>> dup #phi? [
- [ [ phi-in-d>> ] [ out-d>> ] bi rot merge-stuff ]
- [ [ phi-in-r>> ] [ out-r>> ] bi rot merge-stuff ]
- 2bi
- ] [ 2drop ] if ;
+ successor>> propagate-branch-phi ;
M: #branch propagate-around
[ infer-children ] [ merge-children ] [ annotate-node ] tri ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs math math.intervals kernel accessors
sequences namespaces disjoint-sets classes classes.algebra
-combinators words compiler.tree ;
+combinators words compiler.tree compiler.tree.propagation.info ;
IN: compiler.tree.propagation.constraints
! A constraint is a statement about a value.
-! We need a notion of equality which doesn't recurse so cannot
-! infinite loop on circular data
-GENERIC: eql? ( obj1 obj2 -- ? )
-M: object eql? eq? ;
-M: number eql? number= ;
-
-! Maps constraints to constraints
+! Maps constraints to constraints ("A implies B")
SYMBOL: constraints
-TUPLE: literal-constraint literal value ;
-
-C: <literal-constraint> literal-constraint
-
-M: literal-constraint equal?
- over literal-constraint? [
- [ [ literal>> ] bi@ eql? ]
- [ [ value>> ] bi@ = ]
- 2bi and
- ] [ 2drop f ] if ;
-
-TUPLE: class-constraint class value ;
-
-C: <class-constraint> class-constraint
-
-TUPLE: interval-constraint interval value ;
-
-C: <interval-constraint> interval-constraint
+GENERIC: assume ( constraint -- )
+GENERIC: satisfied? ( constraint -- ? )
-GENERIC: apply-constraint ( constraint -- )
-GENERIC: constraint-satisfied? ( constraint -- ? )
+! Boolean constraints
+TUPLE: true-constraint value ;
-: `input ( n -- value ) node get in-d>> nth ;
-: `output ( n -- value ) node get out-d>> nth ;
-: class, ( class value -- ) <class-constraint> , ;
-: literal, ( literal value -- ) <literal-constraint> , ;
-: interval, ( interval value -- ) <interval-constraint> , ;
+: <true-constraint> ( value -- constriant )
+ resolve-copy true-constraint boa ;
-M: f apply-constraint drop ;
+M: true-constraint assume
+ [ constraints get at [ assume ] when* ]
+ [ \ f class-not <class-info> swap value>> refine-value-info ]
+ bi ;
-: make-constraints ( node quot -- constraint )
- [ swap node set call ] { } make ; inline
+M: true-constraint satisfied?
+ value>> value-info class>> \ f class-not class<= ;
-: set-constraints ( node quot -- )
- make-constraints
- unclip [ 2array ] reduce
- apply-constraint ; inline
+TUPLE: false-constraint value ;
-: assume ( constraint -- )
- constraints get at [ apply-constraint ] when* ;
+: <false-constraint> ( value -- constriant )
+ resolve-copy false-constraint boa ;
-! Disjoint set of copy equivalence
-SYMBOL: copies
+M: false-constraint assume
+ [ constraints get at [ assume ] when* ]
+ [ \ f <class-info> swap value>> refine-value-info ]
+ bi ;
-: is-copy-of ( val copy -- ) copies get equate ;
+M: false-constraint satisfied?
+ value>> value-info class>> \ f class-not class<= ;
-: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
+! Class constraints
+TUPLE: class-constraint value class ;
-: resolve-copy ( copy -- val ) copies get representative ;
+: <class-constraint> ( value class -- constraint )
+ [ resolve-copy ] dip class-constraint boa ;
-: introduce-value ( val -- ) copies get add-atom ;
+M: class-constraint assume
+ [ class>> <class-info> ] [ value>> ] bi refine-value-info ;
-! Current value --> literal mapping
-SYMBOL: value-literals
+! Interval constraints
+TUPLE: interval-constraint value interval ;
-! Current value --> interval mapping
-SYMBOL: value-intervals
+: <interval-constraint> ( value interval -- constraint )
+ [ resolve-copy ] dip interval-constraint boa ;
-! Current value --> class mapping
-SYMBOL: value-classes
+M: interval-constraint assume
+ [ interval>> <interval-info> ] [ value>> ] bi refine-value-info ;
-: value-interval ( value -- interval/f )
- resolve-copy value-intervals get at ;
+! Literal constraints
+TUPLE: literal-constraint value literal ;
-: set-value-interval ( interval value -- )
- resolve-copy value-intervals get set-at ;
+: <literal-constraint> ( value literal -- constraint )
+ [ resolve-copy ] dip literal-constraint boa ;
-: intersect-value-interval ( interval value -- )
- resolve-copy value-intervals get [ interval-intersect ] change-at ;
+M: literal-constraint assume
+ [ literal>> <literal-info> ] [ value>> ] bi refine-value-info ;
-M: interval-constraint apply-constraint
- [ interval>> ] [ value>> ] bi intersect-value-interval ;
+! Implication constraints
+TUPLE: implication p q ;
-: set-class-interval ( class value -- )
- over class? [
- [ "interval" word-prop ] dip over
- [ resolve-copy set-value-interval ] [ 2drop ] if
- ] [ 2drop ] if ;
+C: <implication> implication
-: value-class ( value -- class )
- resolve-copy value-classes get at null or ;
-
-: set-value-class ( class value -- )
- resolve-copy over [
- dup value-intervals get at [
- 2dup set-class-interval
- ] unless
- 2dup <class-constraint> assume
- ] when
- value-classes get set-at ;
-
-: intersect-value-class ( class value -- )
- resolve-copy value-classes get [ class-and ] change-at ;
-
-M: class-constraint apply-constraint
- [ class>> ] [ value>> ] bi intersect-value-class ;
-
-: literal-interval ( value -- interval/f )
- dup real? [ [a,a] ] [ drop f ] if ;
+M: implication assume
+ [ q>> ] [ p>> ] bi
+ [ constraints get set-at ]
+ [ satisfied? [ assume ] [ drop ] if ] 2bi ;
-: value-literal ( value -- obj ? )
- resolve-copy value-literals get at* ;
+! Conjunction constraints
+TUPLE: conjunction p q ;
-: set-value-literal ( literal value -- )
- resolve-copy {
- [ [ class ] dip set-value-class ]
- [ [ literal-interval ] dip set-value-interval ]
- [ <literal-constraint> assume ]
- [ value-literals get set-at ]
- } 2cleave ;
+C: <conjunction> conjunction
-M: literal-constraint apply-constraint
- [ literal>> ] [ value>> ] bi set-value-literal ;
+M: conjunction assume [ p>> assume ] [ q>> assume ] bi ;
-M: literal-constraint constraint-satisfied?
- dup value>> value-literal
- [ swap literal>> eql? ] [ 2drop f ] if ;
+! No-op
+M: f assume drop ;
-M: class-constraint constraint-satisfied?
- [ value>> value-class ] [ class>> ] bi class<= ;
+! Utilities
+: if-true ( constraint boolean-value -- constraint' )
+ <true-constraint> swap <implication> ;
-M: pair apply-constraint
- first2
- [ constraints get set-at ]
- [ constraint-satisfied? [ apply-constraint ] [ drop ] if ] 2bi ;
+: if-false ( constraint boolean-value -- constraint' )
+ <false-constraint> swap <implication> ;
-M: pair constraint-satisfied?
- first constraint-satisfied? ;
+: <conditional> ( true-constr false-constr boolean-value -- constraint )
+ tuck [ if-true ] [ if-false ] 2bi* <conjunction> ;
--- /dev/null
+USING: accessors math math.intervals sequences classes.algebra
+math kernel tools.test compiler.tree.propagation.info ;
+IN: compiler.tree.propagation.info.tests
+
+[ t ] [
+ number <class-info>
+ sequence <class-info>
+ value-info-intersect
+ class>> integer class=
+] unit-test
+
+[ t t ] [
+ 0 10 [a,b] <interval-info>
+ 5 20 [a,b] <interval-info>
+ value-info-intersect
+ [ class>> real class= ]
+ [ interval>> 5 10 [a,b] = ]
+ bi
+] unit-test
+
+[ float 10.0 t ] [
+ 10.0 <literal-info>
+ 10.0 <literal-info>
+ value-info-intersect
+ [ class>> ] [ >literal< ] bi
+] unit-test
+
+[ null ] [
+ 10 <literal-info>
+ 10.0 <literal-info>
+ value-info-intersect
+ class>>
+] unit-test
+
+[ fixnum 10 t ] [
+ 10 <literal-info>
+ 10 <literal-info>
+ value-info-union
+ [ class>> ] [ >literal< ] bi
+] unit-test
+
+[ 3.0 t ] [
+ 3 3 [a,b] <interval-info> float <class-info>
+ value-info-intersect >literal<
+] unit-test
+
+[ 3 t ] [
+ 2 3 (a,b] <interval-info> fixnum <class-info>
+ value-info-intersect >literal<
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs classes classes.algebra kernel accessors math
+math.intervals namespaces disjoint-sets sequences words
+combinators ;
+IN: compiler.tree.propagation.info
+
+SYMBOL: +interval+
+
+GENERIC: eql? ( obj1 obj2 -- ? )
+M: object eql? eq? ;
+M: number eql? [ [ class ] bi@ = ] [ number= ] 2bi and ;
+
+! Disjoint set of copy equivalence
+SYMBOL: copies
+
+: is-copy-of ( val copy -- ) copies get equate ;
+
+: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
+
+: resolve-copy ( copy -- val ) copies get representative ;
+
+: introduce-value ( val -- ) copies get add-atom ;
+
+! Value info represents a set of objects. Don't mutate value infos
+! you receive, always construct new ones. We don't declare the
+! slots read-only to allow cloning followed by writing.
+TUPLE: value-info
+{ class initial: null }
+interval
+literal
+literal? ;
+
+: class-interval ( class -- interval )
+ dup real class<=
+ [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
+
+: interval>literal ( class interval -- literal literal? )
+ dup from>> first {
+ { [ over interval-length 0 > ] [ 3drop f f ] }
+ { [ over from>> second not ] [ 3drop f f ] }
+ { [ over to>> second not ] [ 3drop f f ] }
+ { [ pick fixnum class<= ] [ 2nip >fixnum t ] }
+ { [ pick bignum class<= ] [ 2nip >bignum t ] }
+ { [ pick float class<= ] [ 2nip >float t ] }
+ [ 3drop f f ]
+ } cond ;
+
+: <value-info> ( class interval literal literal? -- info )
+ [
+ 2nip
+ [ class ]
+ [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ]
+ [ ]
+ tri t
+ ] [
+ drop
+ over null class<= [ drop f f f ] [
+ over integer class<= [ integral-closure ] when
+ 2dup interval>literal
+ ] if
+ ] if
+ \ value-info boa ; foldable
+
+: <class-info> ( class -- info )
+ [-inf,inf] f f <value-info> ; foldable
+
+: <interval-info> ( interval -- info )
+ real swap f f <value-info> ; foldable
+
+: <literal-info> ( literal -- info )
+ f [-inf,inf] rot t <value-info> ; foldable
+
+: >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ;
+
+: intersect-literals ( info1 info2 -- literal literal? )
+ {
+ { [ dup literal?>> not ] [ drop >literal< ] }
+ { [ over literal?>> not ] [ nip >literal< ] }
+ { [ 2dup [ literal>> ] bi@ eql? not ] [ 2drop f f ] }
+ [ drop >literal< ]
+ } cond ;
+
+: interval-intersect' ( i1 i2 -- i3 )
+ #! Change core later.
+ 2dup and [ interval-intersect ] [ 2drop f ] if ;
+
+: value-info-intersect ( info1 info2 -- info )
+ [ [ class>> ] bi@ class-and ]
+ [ [ interval>> ] bi@ interval-intersect' ]
+ [ intersect-literals ]
+ 2tri <value-info> ;
+
+: interval-union' ( i1 i2 -- i3 )
+ {
+ { [ dup not ] [ drop ] }
+ { [ over not ] [ nip ] }
+ [ interval-union ]
+ } cond ;
+
+: union-literals ( info1 info2 -- literal literal? )
+ 2dup [ literal?>> ] both? [
+ [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
+ ] [ 2drop f f ] if ;
+
+: value-info-union ( info1 info2 -- info )
+ [ [ class>> ] bi@ class-or ]
+ [ [ interval>> ] bi@ interval-union' ]
+ [ union-literals ]
+ 2tri <value-info> ;
+
+: value-infos-union ( infos -- info )
+ dup first [ value-info-union ] reduce ;
+
+! Current value --> info mapping
+SYMBOL: value-infos
+
+: value-info ( value -- info )
+ resolve-copy value-infos get at T{ value-info } or ;
+
+: set-value-info ( info value -- )
+ resolve-copy value-infos get set-at ;
+
+: refine-value-info ( info value -- )
+ resolve-copy value-infos get [ value-info-intersect ] change-at ;
+
+: value-literal ( value -- obj ? )
+ value-info >literal< ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel effects accessors math math.private math.libm
+math.partial-dispatch math.intervals layouts words sequences
+sequences.private arrays assocs classes classes.algebra
+combinators generic.math fry locals
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
+compiler.tree.propagation.constraints ;
+IN: compiler.tree.propagation.known-words
+
+\ fixnum
+most-negative-fixnum most-positive-fixnum [a,b]
++interval+ set-word-prop
+
+\ array-capacity
+0 max-array-capacity [a,b]
++interval+ set-word-prop
+
+{ + - * / }
+[ { number number } "input-classes" set-word-prop ] each
+
+{ /f < > <= >= }
+[ { real real } "input-classes" set-word-prop ] each
+
+{ /i mod /mod }
+[ { rational rational } "input-classes" set-word-prop ] each
+
+{ bitand bitor bitxor bitnot shift }
+[ { integer integer } "input-classes" set-word-prop ] each
+
+\ bitnot { integer } "input-classes" set-word-prop
+
+{
+ fcosh
+ flog
+ fsinh
+ fexp
+ fasin
+ facosh
+ fasinh
+ ftanh
+ fatanh
+ facos
+ fpow
+ fatan
+ fatan2
+ fcos
+ ftan
+ fsin
+ fsqrt
+} [
+ dup stack-effect
+ [ in>> length real <repetition> "input-classes" set-word-prop ]
+ [ out>> length float <repetition> "default-output-classes" set-word-prop ]
+ 2bi
+] each
+
+: ?change-interval ( info quot -- quot' )
+ over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
+
+{ bitnot fixnum-bitnot bignum-bitnot } [
+ [ [ interval-bitnot ] ?change-interval ] +outputs+ set-word-prop
+] each
+
+\ abs [ [ interval-abs ] ?change-interval ] +outputs+ set-word-prop
+
+: math-closure ( class -- newclass )
+ { null fixnum bignum integer rational float real number }
+ [ class<= ] with find nip number or ;
+
+: interval-subset?' ( i1 i2 -- ? )
+ {
+ { [ over not ] [ 2drop t ] }
+ { [ dup not ] [ 2drop f ] }
+ [ interval-subset? ]
+ } cond ;
+
+: fits? ( interval class -- ? )
+ +interval+ word-prop interval-subset?' ;
+
+: binary-op-class ( info1 info2 -- newclass )
+ [ class>> math-closure ] bi@ math-class-max ;
+
+: binary-op-interval ( info1 info2 quot -- newinterval )
+ [ [ interval>> ] bi@ 2dup and ] dip [ 2drop f ] if ; inline
+
+: <class/interval-info> ( class interval -- info )
+ [ f f <value-info> ] [ <class-info> ] if* ;
+
+: won't-overflow? ( class interval -- ? )
+ [ fixnum class<= ] [ fixnum fits? ] bi* and ;
+
+: may-overflow ( class interval -- class' interval' )
+ 2dup won't-overflow?
+ [ [ integer math-class-max ] dip ] unless ;
+
+: may-be-rational ( class interval -- class' interval' )
+ over null class<= [
+ [ rational math-class-max ] dip
+ ] unless ;
+
+: integer-valued ( class interval -- class' interval' )
+ [ integer math-class-min ] dip ;
+
+: real-valued ( class interval -- class' interval' )
+ [ real math-class-min ] dip ;
+
+: float-valued ( class interval -- class' interval' )
+ over null class<= [
+ [ drop float ] dip
+ ] unless ;
+
+: binary-op ( word interval-quot post-proc-quot -- )
+ '[
+ [ binary-op-class ] [ , binary-op-interval ] 2bi
+ @
+ <class/interval-info>
+ ] +outputs+ set-word-prop ;
+
+\ + [ [ interval+ ] [ may-overflow ] binary-op ] each-derived-op
+\ + [ [ interval+ ] [ ] binary-op ] each-fast-derived-op
+
+\ - [ [ interval+ ] [ may-overflow ] binary-op ] each-derived-op
+\ - [ [ interval+ ] [ ] binary-op ] each-fast-derived-op
+
+\ * [ [ interval* ] [ may-overflow ] binary-op ] each-derived-op
+\ * [ [ interval* ] [ ] binary-op ] each-fast-derived-op
+
+\ shift [ [ interval-shift-safe ] [ may-overflow ] binary-op ] each-derived-op
+\ shift [ [ interval-shift-safe ] [ ] binary-op ] each-fast-derived-op
+
+\ / [ [ interval/-safe ] [ may-be-rational ] binary-op ] each-derived-op
+\ /i [ [ interval/i ] [ may-overflow integer-valued ] binary-op ] each-derived-op
+\ /f [ [ interval/f ] [ float-valued ] binary-op ] each-derived-op
+
+\ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
+\ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
+
+\ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
+\ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
+\ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
+
+: assume-interval ( i1 i2 op -- i3 )
+ {
+ { \ < [ assume< ] }
+ { \ > [ assume> ] }
+ { \ <= [ assume<= ] }
+ { \ >= [ assume>= ] }
+ } case ;
+
+: swap-comparison ( op -- op' )
+ {
+ { < > }
+ { > < }
+ { <= >= }
+ { >= <= }
+ } at ;
+
+: negate-comparison ( op -- op' )
+ {
+ { < >= }
+ { > <= }
+ { <= > }
+ { >= < }
+ } at ;
+
+:: (comparison-constraints) ( in1 in2 op -- constraint )
+ [let | i1 [ in1 value-info interval>> ]
+ i2 [ in2 value-info interval>> ] |
+ i1 i2 and [
+ in1 i1 i2 op assume-interval <interval-constraint>
+ in2 i2 i1 op swap-comparison assume-interval <interval-constraint>
+ <conjunction>
+ ] [
+ f
+ ] if
+ ] ;
+
+: comparison-constraints ( in1 in2 out op -- constraint )
+ swap [
+ [ (comparison-constraints) ]
+ [ negate-comparison (comparison-constraints) ]
+ 3bi
+ ] dip <conditional> ;
+
+: comparison-op ( word op -- )
+ '[
+ [ in-d>> first2 ] [ out-d>> first ] bi
+ , comparison-constraints
+ ] +constraints+ set-word-prop ;
+
+{ < > <= >= } [ dup [ comparison-op ] curry each-derived-op ] each
+
+{
+ { >fixnum fixnum }
+ { >bignum bignum }
+ { >float float }
+} [
+ '[
+ ,
+ [ nip ] [
+ [ interval>> ] [ class-interval ] bi*
+ interval-intersect'
+ ] 2bi
+ <class/interval-info>
+ ] +outputs+ set-word-prop
+] assoc-each
+
+!
+! {
+! alien-signed-1
+! alien-unsigned-1
+! alien-signed-2
+! alien-unsigned-2
+! alien-signed-4
+! alien-unsigned-4
+! alien-signed-8
+! alien-unsigned-8
+! } [
+! dup name>> {
+! {
+! [ "alien-signed-" ?head ]
+! [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
+! }
+! {
+! [ "alien-unsigned-" ?head ]
+! [ string>number 8 * 2^ 1- 0 swap [a,b] ]
+! }
+! } cond 1array
+! [ nip f swap ] curry "output-classes" set-word-prop
+! ] each
+!
+!
+! { <tuple> <tuple-boa> (tuple) } [
+! [
+! dup node-in-d peek node-literal
+! dup tuple-layout? [ class>> ] [ drop tuple ] if
+! 1array f
+! ] "output-classes" set-word-prop
+! ] each
+!
+! \ new [
+! dup node-in-d peek node-literal
+! dup class? [ drop tuple ] unless 1array f
+! ] "output-classes" set-word-prop
+!
+! ! the output of clone has the same type as the input
+! { clone (clone) } [
+! [
+! node-in-d [ value-class* ] map f
+! ] "output-classes" set-word-prop
+! ] each
+!
+! ! if the result of eq? is t and the second input is a literal,
+! ! the first input is equal to the second
+! \ eq? [
+! dup node-in-d second dup value? [
+! swap [
+! value-literal 0 `input literal,
+! \ f class-not 0 `output class,
+! ] set-constraints
+! ] [
+! 2drop
+! ] if
+! ] "constraints" set-word-prop
+
+: and-constraints ( in1 in2 out -- constraint )
+ [ [ <true-constraint> ] bi@ ] dip <conditional> ;
+
+! XXX...
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences accessors kernel
+compiler.tree.def-use
+compiler.tree.propagation.info ;
+IN: compiler.tree.propagation.nodes
+
+SYMBOL: +constraints+
+SYMBOL: +outputs+
+
+GENERIC: propagate-before ( node -- )
+
+GENERIC: propagate-after ( node -- )
+
+GENERIC: propagate-around ( node -- )
+
+: (propagate) ( node -- )
+ [
+ [ node-defs-values [ introduce-value ] each ]
+ [ propagate-around ]
+ [ successor>> ]
+ tri
+ (propagate)
+ ] when* ;
--- /dev/null
+USING: kernel compiler.frontend compiler.tree
+compiler.tree.propagation tools.test math accessors
+sequences arrays kernel.private ;
+IN: compiler.tree.propagation.tests
+
+: final-info ( quot -- seq )
+ dataflow propagate last-node node-input-infos ;
+
+: final-classes ( quot -- seq )
+ final-info [ class>> ] map ;
+
+: final-literals ( quot -- seq )
+ final-info [ literal>> ] map ;
+
+[ V{ } ] [ [ ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ 1 >r r> ] final-classes ] unit-test
+
+[ V{ fixnum object } ] [ [ 1 swap ] final-classes ] unit-test
+
+[ V{ array } ] [ [ 10 f <array> ] final-classes ] unit-test
+
+[ V{ array } ] [ [ { array } declare ] final-classes ] unit-test
+
+[ V{ array } ] [ [ 10 f <array> swap [ ] [ ] if ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ dup fixnum? [ ] [ drop 3 ] if ] final-classes ] unit-test
+
+[ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
+
+[ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
+
+[ V{ number } ] [ [ + ] final-classes ] unit-test
+
+[ V{ float } ] [ [ { float integer } declare + ] final-classes ] unit-test
+
+[ V{ float } ] [ [ /f ] final-classes ] unit-test
+
+[ V{ integer } ] [ [ /i ] final-classes ] unit-test
+
+[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
+
+[ V{ integer } ] [
+ [ [ 255 bitand ] [ 65535 bitand ] bi + ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+ [
+ { fixnum } declare [ 255 bitand ] [ 65535 bitand ] bi +
+ ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+ [ { fixnum } declare [ 255 bitand ] keep + ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+ [ { fixnum } declare 615949 * ] final-classes
+] unit-test
+
+[ V{ null } ] [
+ [ { null null } declare + ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+ [ { null fixnum } declare + ] final-classes
+] unit-test
+
+[ V{ float } ] [
+ [ { float fixnum } declare + ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+ [ 255 bitand >fixnum 3 bitor ] final-classes
+] unit-test
+
+[ V{ 0 } ] [
+ [ >fixnum 1 mod ] final-literals
+] unit-test
+
+[ V{ 69 } ] [
+ [ >fixnum swap [ 1 mod 69 + ] [ drop 69 ] if ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+ [ >fixnum dup 10 > [ 1 - ] when ] final-classes
+] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences namespaces hashtables
+disjoint-sets
compiler.tree
compiler.tree.def-use
-compiler.tree.propagation.constraints
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
compiler.tree.propagation.simple
compiler.tree.propagation.branches
-compiler.tree.propagation.recursive ;
+compiler.tree.propagation.recursive
+compiler.tree.propagation.constraints
+compiler.tree.propagation.known-words ;
IN: compiler.tree.propagation
-: (propagate) ( node -- )
- [
- [ node-defs-values [ introduce-value ] each ]
- [ propagate-around ]
- [ successor>> ]
- tri
- (propagate)
- ] when* ;
-
-: propagate-with ( node classes literals intervals -- )
+: propagate-with ( node infos -- )
[
H{ } clone constraints set
- >hashtable value-intervals set
- >hashtable value-literals set
- >hashtable value-classes set
+ >hashtable value-infos set
+ <disjoint-set> copies set
(propagate)
] with-scope ;
: propagate ( node -- node )
- dup f f f propagate-with ;
+ dup f propagate-with ;
: propagate/node ( node existing -- )
- #! Infer classes, using the existing node's class info as a
- #! starting point.
- [ classes>> ] [ literals>> ] [ intervals>> ] tri
- propagate-with ;
+ info>> propagate-with ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.tree compiler.tree.propagation.simple
+USING: kernel sequences accessors
+compiler.tree
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
+compiler.tree.propagation.simple
compiler.tree.propagation.branches ;
IN: compiler.tree.propagation.recursive
-! M: #recursive child-constraints
-! drop { f } ;
-!
-! M: #recursive propagate-around
-! [ infer-children ] [ merge-children ] [ annotate-node ] tri ;
-!
-! : classes= ( inferred current -- ? )
-! 2dup min-length '[ , tail* ] bi@ sequence= ;
-!
-! SYMBOL: fixed-point?
-!
-! SYMBOL: nested-labels
-!
-! : annotate-entry ( nodes #label -- )
-! [ (merge-classes) ] dip node-child
-! 2dup node-output-classes classes=
-! [ 2drop ] [ set-classes fixed-point? off ] if ;
-!
-! : init-recursive-calls ( #label -- )
-! #! We set recursive calls to output the empty type, then
-! #! repeat inference until a fixed point is reached.
-! #! Hopefully, our type functions are monotonic so this
-! #! will always converge.
-! returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
-!
-! M: #label propagate-before ( #label -- )
-! [ init-recursive-calls ]
-! [ [ 1array ] keep annotate-entry ] bi ;
-!
-! : infer-label-loop ( #label -- )
-! fixed-point? on
-! dup node-child (propagate)
-! dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
-! fixed-point? get [ drop ] [ infer-label-loop ] if ;
-!
-! M: #label propagate-around ( #label -- )
-! #! Now merge the types at every recursion point with the
-! #! entry types.
-! [
-! {
-! [ nested-labels get push ]
-! [ annotate-node ]
-! [ propagate-before ]
-! [ infer-label-loop ]
-! [ drop nested-labels get pop* ]
-! } cleave
-! ] with-scope ;
-!
-! : find-label ( param -- #label )
-! word>> nested-labels get [ word>> eq? ] with find nip ;
-!
-! M: #call-recursive propagate-before ( #call-label -- )
-! [ label>> returns>> (merge-classes) ] [ out-d>> ] bi
-! [ set-value-class ] 2each ;
-!
-! M: #return propagate-around
-! nested-labels get length 0 > [
-! dup word>> nested-labels get peek word>> eq? [
-! [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
-! classes= not [
-! fixed-point? off
-! [ in-d>> value-classes get valid-keys ] keep
-! set-node-classes
-! ] [ drop ] if
-! ] [ call-next-method ] if
-! ] [ call-next-method ] if ;
+: (merge-value-infos) ( inputs -- infos )
+ [ [ value-info ] map value-infos-union ] map ;
+
+: merge-value-infos ( inputs outputs -- fixed-point? )
+ [ (merge-value-infos) ] dip
+ [ 2dup value-info = [ 2drop t ] [ set-value-info f ] if ] 2all? ;
+
+: propagate-recursive-phi ( #phi -- fixed-point? )
+ [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
+ [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
+ bi and ;
+
+M: #recursive propagate-around ( #recursive -- )
+ dup
+ [ children>> (propagate) ]
+ [ node-child propagate-recursive-phi ] bi
+ [ drop ] [ propagate-around ] if ;
+
+M: #call-recursive propagate-before ( #call-label -- )
+ #! What if we reach a fixed point for the phi but not for the
+ #! #call-label output?
+ [ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences assocs words namespaces
-combinators classes.algebra compiler.tree
+classes.algebra combinators classes
+compiler.tree
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
compiler.tree.propagation.constraints ;
IN: compiler.tree.propagation.simple
-GENERIC: propagate-before ( node -- )
-
M: #introduce propagate-before
- values>> [ object swap set-value-class ] each ;
+ object <class-info> swap values>> [ set-value-info ] with each ;
M: #push propagate-before
- [ literal>> ] [ out-d>> first ] bi set-value-literal ;
+ [ literal>> value>> <literal-info> ] [ out-d>> first ] bi
+ set-value-info ;
+
+: refine-value-infos ( classes values -- )
+ [ refine-value-info ] 2each ;
+
+: class-infos ( classes -- infos )
+ [ <class-info> ] map ;
+
+: set-value-infos ( infos values -- )
+ [ set-value-info ] 2each ;
M: #declare propagate-before
[ [ in-d>> ] [ out-d>> ] bi are-copies-of ]
- [ [ declaration>> ] [ out-d>> ] bi [ intersect-value-class ] 2each ]
- bi ;
+ [
+ [ declaration>> class-infos ] [ out-d>> ] bi
+ refine-value-infos
+ ] bi ;
M: #shuffle propagate-before
- [ out-r>> dup ] [ mapping>> ] bi '[ , at ] map are-copies-of ;
+ [ out-d>> dup ] [ mapping>> ] bi
+ '[ , at ] map swap are-copies-of ;
M: #>r propagate-before
[ in-d>> ] [ out-r>> ] bi are-copies-of ;
M: #copy propagate-before
[ in-d>> ] [ out-d>> ] bi are-copies-of ;
-: intersect-classes ( classes values -- )
- [ intersect-value-class ] 2each ;
+: predicate-constraints ( value class boolean-value -- constraint )
+ [ [ <class-constraint> ] dip if-true ]
+ [ [ class-not <class-constraint> ] dip if-false ]
+ 3bi <conjunction> ;
-: intersect-intervals ( intervals values -- )
- [ intersect-value-interval ] 2each ;
-
-: predicate-constraints ( class #call -- )
- [
- ! If word outputs true, input is an instance of class
- [
- 0 `input class,
- \ f class-not 0 `output class,
- ] set-constraints
- ] [
- ! If word outputs false, input is not an instance of class
+: compute-constraints ( #call -- constraint )
+ dup word>> +constraints+ word-prop [ call assume ] [
+ dup word>> predicate?
[
- class-not 0 `input class,
- \ f 0 `output class,
- ] set-constraints
- ] 2bi ;
-
-: compute-constraints ( #call -- )
- dup word>> "constraints" word-prop [
- call
- ] [
- dup word>> "predicating" word-prop dup
- [ swap predicate-constraints ] [ 2drop ] if
+ [ in-d>> first ]
+ [ word>> "predicating" word-prop ]
+ [ out-d>> first ]
+ tri predicate-constraints assume
+ ] [ drop ] if
] if* ;
-: compute-output-classes ( node word -- classes intervals )
- dup word>> "output-classes" word-prop
- dup [ call ] [ 2drop f f ] if ;
+: default-output-value-infos ( node -- infos )
+ dup word>> "default-output-classes" word-prop [
+ class-infos
+ ] [
+ out-d>> length object <class-info> <repetition>
+ ] ?if ;
-: output-classes ( node -- classes intervals )
- dup compute-output-classes [
- [ ] [ word>> "default-output-classes" word-prop ] ?if
- ] dip ;
+: call-outputs-quot ( node quot -- infos )
+ [ in-d>> [ value-info ] map ] dip with-datastack ;
-: intersect-values ( classes intervals values -- )
- tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
+: output-value-infos ( node word -- infos )
+ dup word>> +outputs+ word-prop
+ [ call-outputs-quot ] [ default-output-value-infos ] if* ;
M: #call propagate-before
[ compute-constraints ]
- [ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ;
+ [ [ output-value-infos ] [ out-d>> ] bi set-value-infos ] bi ;
M: node propagate-before drop ;
-GENERIC: propagate-after ( node -- )
-
-: input-classes ( #call -- classes )
- word>> "input-classes" word-prop ;
-
M: #call propagate-after
- [ input-classes ] [ in-d>> ] bi intersect-classes ;
+ dup word>> "input-classes" word-prop dup [
+ class-infos swap in-d>> refine-value-infos
+ ] [
+ 2drop
+ ] if ;
M: node propagate-after drop ;
-GENERIC: propagate-around ( node -- )
-
-: valid-keys ( seq assoc -- newassoc )
- '[ dup resolve-copy , at ] H{ } map>assoc
- [ nip ] assoc-filter
- f assoc-like ;
-
: annotate-node ( node -- )
- #! Annotate the node with the currently-inferred set of
- #! value classes.
- dup node-values {
- [ value-intervals get valid-keys >>intervals ]
- [ value-classes get valid-keys >>classes ]
- [ value-literals get valid-keys >>literals ]
- [ 2drop ]
- } cleave ;
-
-M: object propagate-around
- {
- [ propagate-before ]
- [ annotate-node ]
- [ propagate-after ]
- } cleave ;
+ dup node-values [ dup value-info ] H{ } map>assoc >>info drop ;
+
+M: node propagate-around
+ [ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;
! 3) A value is never used in the same node where it is defined.
TUPLE: node < identity-tuple
-in-d out-d in-r out-r
-classes literals intervals
+in-d out-d in-r out-r info
history successor children ;
M: node hashcode* drop node hashcode* ;
{ [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
4array concat ;
-: node-child ( node -- child ) node-children first ;
+: node-child ( node -- child ) children>> first ;
: last-node ( node -- last )
dup successor>> [ last-node ] [ ] ?if ;
2drop f
] if ;
-: node-literal? ( node value -- ? )
- swap literals>> key? ;
+: node-value-info ( node value -- info )
+ swap info>> at ;
-: node-literal ( node value -- obj )
- swap literals>> at ;
+: node-input-infos ( node -- seq )
+ dup in-d>> [ node-value-info ] with map ;
-: node-interval ( node value -- interval )
- swap intervals>> at ;
-
-: node-class ( node value -- class )
- swap classes>> at ;
-
-: node-input-classes ( node -- seq )
- dup in-d>> [ node-class ] with map ;
-
-: node-output-classes ( node -- seq )
- dup out-d>> [ node-class ] with map ;
-
-: node-input-intervals ( node -- seq )
- dup in-d>> [ node-interval ] with map ;
-
-: node-class-first ( node -- class )
- dup in-d>> first node-class ;
+: node-output-infos ( node -- seq )
+ dup out-d>> [ node-value-info ] with map ;
TUPLE: #introduce < node values ;
--- /dev/null
+IN: optimizer.math.partial.tests
+USING: math.partial-dispatch tools.test math kernel sequences ;
+
+[ t ] [ \ + integer fixnum math-both-known? ] unit-test
+[ t ] [ \ + bignum fixnum math-both-known? ] unit-test
+[ t ] [ \ + integer bignum math-both-known? ] unit-test
+[ t ] [ \ + float fixnum math-both-known? ] unit-test
+[ f ] [ \ + real fixnum math-both-known? ] unit-test
+[ f ] [ \ + object number math-both-known? ] unit-test
+[ f ] [ \ number= fixnum object math-both-known? ] unit-test
+[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
+[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel kernel.private math math.private words
+sequences parser namespaces assocs quotations arrays
+generic generic.math hashtables effects compiler.units ;
+IN: math.partial-dispatch
+
+! Partial dispatch.
+
+! This code will be overhauled and generalized when
+! multi-methods go into the core.
+PREDICATE: math-partial < word
+ "derived-from" word-prop >boolean ;
+
+: fixnum-integer-op ( a b fix-word big-word -- c )
+ pick tag 0 eq? [
+ drop execute
+ ] [
+ >r drop >r fixnum>bignum r> r> execute
+ ] if ; inline
+
+: integer-fixnum-op ( a b fix-word big-word -- c )
+ >r pick tag 0 eq? [
+ r> drop execute
+ ] [
+ drop fixnum>bignum r> execute
+ ] if ; inline
+
+: integer-integer-op ( a b fix-word big-word -- c )
+ pick tag 0 eq? [
+ integer-fixnum-op
+ ] [
+ >r drop over tag 0 eq? [
+ >r fixnum>bignum r> r> execute
+ ] [
+ r> execute
+ ] if
+ ] if ; inline
+
+: integer-op-combinator ( triple -- word )
+ [
+ [ second name>> % "-" % ]
+ [ third name>> % "-op" % ]
+ bi
+ ] "" make "math.partial-dispatch" lookup ;
+
+: integer-op-word ( triple fix-word big-word -- word )
+ [
+ drop
+ name>> "fast" tail? >r
+ [ "-" % ] [ name>> % ] interleave
+ r> [ "-fast" % ] when
+ ] "" make "math.partial-dispatch" create ;
+
+: integer-op-quot ( word fix-word big-word -- quot )
+ rot integer-op-combinator 1quotation 2curry ;
+
+: define-integer-op-word ( word fix-word big-word -- )
+ [
+ [ integer-op-word ] [ integer-op-quot ] 3bi
+ (( x y -- z )) define-declared
+ ]
+ [
+ [ integer-op-word ] [ 2drop ] 3bi
+ "derived-from" set-word-prop
+ ] 3bi ;
+
+: define-integer-op-words ( words fix-word big-word -- )
+ [ define-integer-op-word ] 2curry each ;
+
+: integer-op-triples ( word -- triples )
+ {
+ { fixnum integer }
+ { integer fixnum }
+ { integer integer }
+ } swap [ prefix ] curry map ;
+
+: define-integer-ops ( word fix-word big-word -- )
+ >r >r integer-op-triples r> r>
+ [ define-integer-op-words ]
+ [ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ]
+ 3bi ;
+
+: define-math-ops ( op -- )
+ { fixnum bignum float }
+ [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
+ [ nip ] assoc-filter
+ [ def>> peek ] assoc-map % ;
+
+SYMBOL: math-ops
+
+SYMBOL: fast-math-ops
+
+: math-op ( word left right -- word' ? )
+ 3array math-ops get at* ;
+
+: math-method* ( word left right -- quot )
+ 3dup math-op
+ [ >r 3drop r> 1quotation ] [ drop math-method ] if ;
+
+: math-both-known? ( word left right -- ? )
+ 3dup math-op
+ [ 2drop 2drop t ]
+ [ drop math-class-max swap specific-method >boolean ] if ;
+
+: (derived-ops) ( word assoc -- words )
+ swap [ rot first eq? nip ] curry assoc-filter values ;
+
+: derived-ops ( word -- words )
+ [ 1array ]
+ [ math-ops get (derived-ops) ]
+ bi append ;
+
+: fast-derived-ops ( word -- words )
+ fast-math-ops get (derived-ops) ;
+
+: all-derived-ops ( word -- words )
+ [ derived-ops ] [ fast-derived-ops ] bi append ;
+
+: each-derived-op ( word quot -- )
+ >r derived-ops r> each ; inline
+
+: each-fast-derived-op ( word quot -- )
+ >r fast-derived-ops r> each ; inline
+
+[
+ [
+ \ + define-math-ops
+ \ - define-math-ops
+ \ * define-math-ops
+ \ shift define-math-ops
+ \ mod define-math-ops
+ \ /i define-math-ops
+
+ \ bitand define-math-ops
+ \ bitor define-math-ops
+ \ bitxor define-math-ops
+
+ \ < define-math-ops
+ \ <= define-math-ops
+ \ > define-math-ops
+ \ >= define-math-ops
+ \ number= define-math-ops
+
+ \ + \ fixnum+ \ bignum+ define-integer-ops
+ \ - \ fixnum- \ bignum- define-integer-ops
+ \ * \ fixnum* \ bignum* define-integer-ops
+ \ shift \ fixnum-shift \ bignum-shift define-integer-ops
+ \ mod \ fixnum-mod \ bignum-mod define-integer-ops
+ \ /i \ fixnum/i \ bignum/i define-integer-ops
+
+ \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
+ \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
+ \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
+
+ \ < \ fixnum< \ bignum< define-integer-ops
+ \ <= \ fixnum<= \ bignum<= define-integer-ops
+ \ > \ fixnum> \ bignum> define-integer-ops
+ \ >= \ fixnum>= \ bignum>= define-integer-ops
+ \ number= \ eq? \ bignum= define-integer-ops
+ ] { } make >hashtable math-ops set-global
+
+ [
+ { { + fixnum fixnum } fixnum+fast } ,
+ { { - fixnum fixnum } fixnum-fast } ,
+ { { * fixnum fixnum } fixnum*fast } ,
+ { { shift fixnum fixnum } fixnum-shift-fast } ,
+
+ \ + \ fixnum+fast \ bignum+ define-integer-ops
+ \ - \ fixnum-fast \ bignum- define-integer-ops
+ \ * \ fixnum*fast \ bignum* define-integer-ops
+ \ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops
+ ] { } make >hashtable fast-math-ops set-global
+] with-compilation-unit
: phi-inputs ( seq -- newseq )
dup empty? [
dup [ length ] map supremum
- '[ , f pad-left ] map
+ '[ , f pad-left ] map flip
] unless ;
: unify-values ( values -- phi-out )
[ nip first make-known ] [ 2drop <value> ] if ;
: phi-outputs ( phi-in -- stack )
- flip [ unify-values ] map ;
+ [ unify-values ] map ;
SYMBOL: quotations
: retainstack-phi ( seq -- phi-in phi-out )
[ length 0 <repetition> ] [ meta-r active-variable ] bi
unify-branches
- [ drop ] [ ] [ dup meta-r set ] tri* ;
+ [ drop ] [ ] [ dup >vector meta-r set ] tri* ;
: compute-phi-function ( seq -- )
[ quotation active-variable sift quotations set ]
[
[ call-site-stack ] dip
[ check-call-site-stack ]
- [ phi-in>> push ]
+ [ phi-in>> swap [ suffix ] 2change-each ]
2bi
] 2bi ;
\ declare [
pop-literal nip
- [ length consume-d dup copy-values ] keep
+ [ length consume-d dup copy-values dup output-d ] keep
#declare,
] +infer+ set-word-prop
dup zero? [
drop '[ recursive-state get @ ]
] [
- '[
+ swap '[
, consume-d
[ first literal recursion>> ]
[ [ literal value>> ] each ] bi @
projects / factor.git / commitdiff