Working on propagation pass
Slava Pestov
parent
49d34ab8a7
commit
1f27b9252e
|
|
@ -77,8 +77,8 @@ M: #shuffle propagate* mapping>> at look-at-value ;
|
|||
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 ;
|
||||
|
|
@ -139,15 +139,15 @@ M: #copy remove-dead-values* remove-dead-copies ;
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -29,7 +29,8 @@ TUPLE: definition value node uses ;
|
|||
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>> ;
|
||||
|
||||
|
|
@ -43,12 +44,9 @@ M: #>r node-defs-values out-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 [
|
||||
|
|
|
|||
|
|
@ -3,6 +3,9 @@
|
|||
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
|
||||
|
|
@ -11,60 +14,36 @@ 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-value-infos) ( inputs results -- infos )
|
||||
'[ , [ [ value-info ] bind ] 2map value-infos-union ] map ;
|
||||
|
||||
: merge-intervals ( inputs outputs results -- )
|
||||
'[
|
||||
, [ [ value-interval ] bind ] 2map
|
||||
dup first [ interval-union ] reduce
|
||||
_ set-value-interval
|
||||
] 2each ;
|
||||
: merge-value-infos ( results inputs outputs -- )
|
||||
[ swap (merge-value-infos) ] dip set-value-infos ;
|
||||
|
||||
: 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-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 ;
|
||||
|
|
|
|||
|
|
@ -2,145 +2,97 @@
|
|||
! 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 ;
|
||||
GENERIC: assume ( constraint -- )
|
||||
GENERIC: satisfied? ( constraint -- ? )
|
||||
|
||||
C: <literal-constraint> literal-constraint
|
||||
! Boolean constraints
|
||||
TUPLE: true-constraint value ;
|
||||
|
||||
M: literal-constraint equal?
|
||||
over literal-constraint? [
|
||||
[ [ literal>> ] bi@ eql? ]
|
||||
[ [ value>> ] bi@ = ]
|
||||
2bi and
|
||||
] [ 2drop f ] if ;
|
||||
: <true-constraint> ( value -- constriant )
|
||||
resolve-copy true-constraint boa ;
|
||||
|
||||
TUPLE: class-constraint class value ;
|
||||
M: true-constraint assume
|
||||
[ constraints get at [ assume ] when* ]
|
||||
[ \ f class-not <class-info> swap value>> refine-value-info ]
|
||||
bi ;
|
||||
|
||||
C: <class-constraint> class-constraint
|
||||
M: true-constraint satisfied?
|
||||
value>> value-info class>> \ f class-not class<= ;
|
||||
|
||||
TUPLE: interval-constraint interval value ;
|
||||
TUPLE: false-constraint value ;
|
||||
|
||||
C: <interval-constraint> interval-constraint
|
||||
: <false-constraint> ( value -- constriant )
|
||||
resolve-copy false-constraint boa ;
|
||||
|
||||
GENERIC: apply-constraint ( constraint -- )
|
||||
GENERIC: constraint-satisfied? ( constraint -- ? )
|
||||
M: false-constraint assume
|
||||
[ constraints get at [ assume ] when* ]
|
||||
[ \ f <class-info> swap value>> refine-value-info ]
|
||||
bi ;
|
||||
|
||||
: `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> , ;
|
||||
M: false-constraint satisfied?
|
||||
value>> value-info class>> \ f class-not class<= ;
|
||||
|
||||
M: f apply-constraint drop ;
|
||||
! Class constraints
|
||||
TUPLE: class-constraint value class ;
|
||||
|
||||
: make-constraints ( node quot -- constraint )
|
||||
[ swap node set call ] { } make ; inline
|
||||
: <class-constraint> ( value class -- constraint )
|
||||
[ resolve-copy ] dip class-constraint boa ;
|
||||
|
||||
: set-constraints ( node quot -- )
|
||||
make-constraints
|
||||
unclip [ 2array ] reduce
|
||||
apply-constraint ; inline
|
||||
M: class-constraint assume
|
||||
[ class>> <class-info> ] [ value>> ] bi refine-value-info ;
|
||||
|
||||
: assume ( constraint -- )
|
||||
constraints get at [ apply-constraint ] when* ;
|
||||
! Interval constraints
|
||||
TUPLE: interval-constraint value interval ;
|
||||
|
||||
! Disjoint set of copy equivalence
|
||||
SYMBOL: copies
|
||||
: <interval-constraint> ( value interval -- constraint )
|
||||
[ resolve-copy ] dip interval-constraint boa ;
|
||||
|
||||
: is-copy-of ( val copy -- ) copies get equate ;
|
||||
M: interval-constraint assume
|
||||
[ interval>> <interval-info> ] [ value>> ] bi refine-value-info ;
|
||||
|
||||
: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
|
||||
! Literal constraints
|
||||
TUPLE: literal-constraint value literal ;
|
||||
|
||||
: resolve-copy ( copy -- val ) copies get representative ;
|
||||
: <literal-constraint> ( value literal -- constraint )
|
||||
[ resolve-copy ] dip literal-constraint boa ;
|
||||
|
||||
: introduce-value ( val -- ) copies get add-atom ;
|
||||
M: literal-constraint assume
|
||||
[ literal>> <literal-info> ] [ value>> ] bi refine-value-info ;
|
||||
|
||||
! Current value --> literal mapping
|
||||
SYMBOL: value-literals
|
||||
! Implication constraints
|
||||
TUPLE: implication p q ;
|
||||
|
||||
! Current value --> interval mapping
|
||||
SYMBOL: value-intervals
|
||||
C: <implication> implication
|
||||
|
||||
! Current value --> class mapping
|
||||
SYMBOL: value-classes
|
||||
|
||||
: value-interval ( value -- interval/f )
|
||||
resolve-copy value-intervals get at ;
|
||||
|
||||
: set-value-interval ( interval value -- )
|
||||
resolve-copy value-intervals get set-at ;
|
||||
|
||||
: intersect-value-interval ( interval value -- )
|
||||
resolve-copy value-intervals get [ interval-intersect ] change-at ;
|
||||
|
||||
M: interval-constraint apply-constraint
|
||||
[ interval>> ] [ value>> ] bi intersect-value-interval ;
|
||||
|
||||
: set-class-interval ( class value -- )
|
||||
over class? [
|
||||
[ "interval" word-prop ] dip over
|
||||
[ resolve-copy set-value-interval ] [ 2drop ] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: value-literal ( value -- obj ? )
|
||||
resolve-copy value-literals get at* ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
M: literal-constraint apply-constraint
|
||||
[ literal>> ] [ value>> ] bi set-value-literal ;
|
||||
|
||||
M: literal-constraint constraint-satisfied?
|
||||
dup value>> value-literal
|
||||
[ swap literal>> eql? ] [ 2drop f ] if ;
|
||||
|
||||
M: class-constraint constraint-satisfied?
|
||||
[ value>> value-class ] [ class>> ] bi class<= ;
|
||||
|
||||
M: pair apply-constraint
|
||||
first2
|
||||
M: implication assume
|
||||
[ q>> ] [ p>> ] bi
|
||||
[ constraints get set-at ]
|
||||
[ constraint-satisfied? [ apply-constraint ] [ drop ] if ] 2bi ;
|
||||
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
|
||||
|
||||
M: pair constraint-satisfied?
|
||||
first constraint-satisfied? ;
|
||||
! Conjunction constraints
|
||||
TUPLE: conjunction p q ;
|
||||
|
||||
C: <conjunction> conjunction
|
||||
|
||||
M: conjunction assume [ p>> assume ] [ q>> assume ] bi ;
|
||||
|
||||
! No-op
|
||||
M: f assume drop ;
|
||||
|
||||
! Utilities
|
||||
: if-true ( constraint boolean-value -- constraint' )
|
||||
<true-constraint> swap <implication> ;
|
||||
|
||||
: if-false ( constraint boolean-value -- constraint' )
|
||||
<false-constraint> swap <implication> ;
|
||||
|
||||
: <conditional> ( true-constr false-constr boolean-value -- constraint )
|
||||
tuck [ if-true ] [ if-false ] 2bi* <conjunction> ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,50 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,128 @@
|
|||
! 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< ;
|
||||
|
|
@ -0,0 +1,271 @@
|
|||
! 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...
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
! 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* ;
|
||||
|
|
@ -0,0 +1,89 @@
|
|||
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
|
||||
|
|
@ -1,37 +1,28 @@
|
|||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -1,72 +1,32 @@
|
|||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -1,25 +1,39 @@
|
|||
! 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 ;
|
||||
|
|
@ -30,83 +44,53 @@ M: #r> propagate-before
|
|||
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
|
||||
: compute-constraints ( #call -- constraint )
|
||||
dup word>> +constraints+ word-prop [ call assume ] [
|
||||
dup word>> predicate?
|
||||
[
|
||||
0 `input class,
|
||||
\ f class-not 0 `output class,
|
||||
] set-constraints
|
||||
] [
|
||||
! If word outputs false, input is not an instance of class
|
||||
[
|
||||
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 ;
|
||||
dup node-values [ dup value-info ] H{ } map>assoc >>info drop ;
|
||||
|
||||
M: object propagate-around
|
||||
{
|
||||
[ propagate-before ]
|
||||
[ annotate-node ]
|
||||
[ propagate-after ]
|
||||
} cleave ;
|
||||
M: node propagate-around
|
||||
[ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;
|
||||
|
|
|
|||
|
|
@ -18,8 +18,7 @@ IN: compiler.tree
|
|||
! 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* ;
|
||||
|
|
@ -31,7 +30,7 @@ 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 ;
|
||||
|
|
@ -44,29 +43,14 @@ M: node hashcode* drop node hashcode* ;
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,12 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,174 @@
|
|||
! 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
|
||||
|
|
@ -12,7 +12,7 @@ IN: stack-checker.branches
|
|||
: 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 )
|
||||
|
|
@ -20,7 +20,7 @@ IN: stack-checker.branches
|
|||
[ nip first make-known ] [ 2drop <value> ] if ;
|
||||
|
||||
: phi-outputs ( phi-in -- stack )
|
||||
flip [ unify-values ] map ;
|
||||
[ unify-values ] map ;
|
||||
|
||||
SYMBOL: quotations
|
||||
|
||||
|
|
@ -47,7 +47,7 @@ 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 ]
|
||||
|
|
|
|||
|
|
@ -104,7 +104,7 @@ SYMBOL: phi-out
|
|||
[
|
||||
[ call-site-stack ] dip
|
||||
[ check-call-site-stack ]
|
||||
[ phi-in>> push ]
|
||||
[ phi-in>> swap [ suffix ] 2change-each ]
|
||||
2bi
|
||||
] 2bi ;
|
||||
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ IN: stack-checker.known-words
|
|||
|
||||
\ 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
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ IN: stack-checker.transforms
|
|||
dup zero? [
|
||||
drop '[ recursive-state get @ ]
|
||||
] [
|
||||
'[
|
||||
swap '[
|
||||
, consume-d
|
||||
[ first literal recursion>> ]
|
||||
[ [ literal value>> ] each ] bi @
|
||||
|
|
|
|||
Loading…
Reference in New Issue