Improve recursive word type inference
Slava Pestov
parent
3b795b6a07
commit
6dedc433d5
|
|
@ -48,10 +48,6 @@ HELP: no-effect
|
|||
{ $description "Throws a " { $link no-effect } " error." }
|
||||
{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
|
||||
|
||||
HELP: collect-recursion
|
||||
{ $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } }
|
||||
{ $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ;
|
||||
|
||||
HELP: inline-word
|
||||
{ $values { "word" word } }
|
||||
{ $description "Called during inference to infer stack effects of inline words."
|
||||
|
|
|
|||
|
|
@ -409,6 +409,25 @@ TUPLE: recursive-declare-error word ;
|
|||
\ recursive-declare-error inference-error
|
||||
] if* ;
|
||||
|
||||
GENERIC: collect-label-info* ( label node -- )
|
||||
|
||||
M: node collect-label-info* 2drop ;
|
||||
|
||||
: (collect-label-info) ( label node vector -- )
|
||||
>r tuck [ param>> ] bi@ eq? r> [ push ] curry [ drop ] if ;
|
||||
inline
|
||||
|
||||
M: #call-label collect-label-info*
|
||||
over calls>> (collect-label-info) ;
|
||||
|
||||
M: #return collect-label-info*
|
||||
over returns>> (collect-label-info) ;
|
||||
|
||||
: collect-label-info ( #label -- )
|
||||
V{ } clone >>calls
|
||||
V{ } clone >>returns
|
||||
dup [ collect-label-info* ] with each-node ;
|
||||
|
||||
: nest-node ( -- ) #entry node, ;
|
||||
|
||||
: unnest-node ( new-node -- new-node )
|
||||
|
|
@ -419,27 +438,17 @@ TUPLE: recursive-declare-error word ;
|
|||
|
||||
: <inlined-block> gensym dup t "inlined-block" set-word-prop ;
|
||||
|
||||
: inline-block ( word -- node-block data )
|
||||
: inline-block ( word -- #label data )
|
||||
[
|
||||
copy-inference nest-node
|
||||
dup word-def swap <inlined-block>
|
||||
[ infer-quot-recursive ] 2keep
|
||||
#label unnest-node
|
||||
dup collect-label-info
|
||||
] H{ } make-assoc ;
|
||||
|
||||
GENERIC: collect-recursion* ( label node -- )
|
||||
|
||||
M: node collect-recursion* 2drop ;
|
||||
|
||||
M: #call-label collect-recursion*
|
||||
tuck node-param eq? [ , ] [ drop ] if ;
|
||||
|
||||
: collect-recursion ( #label -- seq )
|
||||
dup node-param
|
||||
[ [ swap collect-recursion* ] curry each-node ] { } make ;
|
||||
|
||||
: join-values ( node -- )
|
||||
collect-recursion [ node-in-d ] map meta-d get suffix
|
||||
: join-values ( #label -- )
|
||||
calls>> [ node-in-d ] map meta-d get suffix
|
||||
unify-lengths unify-stacks
|
||||
meta-d [ length tail* ] change ;
|
||||
|
||||
|
|
@ -460,7 +469,7 @@ M: #call-label collect-recursion*
|
|||
drop join-values inline-block apply-infer
|
||||
r> over set-node-in-d
|
||||
dup node,
|
||||
collect-recursion [
|
||||
calls>> [
|
||||
[ flatten-curries ] modify-values
|
||||
] each
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -4,7 +4,12 @@ inference.dataflow optimizer tools.test kernel.private generic
|
|||
sequences words inference.class quotations alien
|
||||
alien.c-types strings sbufs sequences.private
|
||||
slots.private combinators definitions compiler.units
|
||||
system layouts vectors optimizer.math.partial ;
|
||||
system layouts vectors optimizer.math.partial accessors
|
||||
optimizer.inlining ;
|
||||
|
||||
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
|
||||
|
||||
[ f ] [ T{ literal-constraint f 1 3 } T{ literal-constraint f 1 2 } equal? ] unit-test
|
||||
|
||||
! Make sure these compile even though this is invalid code
|
||||
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
|
||||
|
|
@ -268,19 +273,24 @@ M: float detect-float ;
|
|||
[ 3 + = ] \ equal? inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ f ] [
|
||||
[ { fixnum fixnum } declare 7 bitand neg shift ]
|
||||
\ shift inlined?
|
||||
\ fixnum-shift-fast inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare 7 bitand neg shift ]
|
||||
\ fixnum-shift inlined?
|
||||
{ shift fixnum-shift } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
|
||||
\ fixnum-shift inlined?
|
||||
{ shift fixnum-shift } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
|
||||
{ fixnum-shift-fast } inlined?
|
||||
] unit-test
|
||||
|
||||
cell-bits 32 = [
|
||||
|
|
@ -375,25 +385,78 @@ cell-bits 32 = [
|
|||
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
|
||||
] unit-test
|
||||
|
||||
: rec ( a -- b )
|
||||
dup 0 > [ 1 - rec ] when ; inline
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare rec 1 + ]
|
||||
{ > - + } inlined?
|
||||
] unit-test
|
||||
|
||||
: fib ( m -- n )
|
||||
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ 27.0 fib ] { < - } inlined?
|
||||
[ 27.0 fib ] { < - + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ 27.0 fib ] { +-integer-integer } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 27 fib ] { < - } inlined?
|
||||
[ 27 fib ] { < - + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 27 >bignum fib ] { < - } inlined?
|
||||
[ 27 >bignum fib ] { < - + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ 27/2 fib ] { < - } inlined?
|
||||
] unit-test
|
||||
|
||||
: hang-regression ( m n -- x )
|
||||
over 0 number= [
|
||||
nip
|
||||
] [
|
||||
dup [
|
||||
drop 1 hang-regression
|
||||
] [
|
||||
dupd hang-regression hang-regression
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
|
||||
] { } inlined? ] unit-test
|
||||
|
||||
: detect-null ( a -- b ) dup drop ;
|
||||
|
||||
\ detect-null {
|
||||
{ [ dup dup in-d>> first node-class null eq? ] [ [ ] f splice-quot ] }
|
||||
} define-optimizers
|
||||
|
||||
[ t ] [
|
||||
[ { null } declare detect-null ] \ detect-null inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { null null } declare + detect-null ] \ detect-null inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { null fixnum } declare + detect-null ] \ detect-null inlined?
|
||||
] unit-test
|
||||
|
||||
GENERIC: detect-integer ( a -- b )
|
||||
|
||||
M: integer detect-integer ;
|
||||
|
||||
[ t ] [
|
||||
[ { null fixnum } declare + detect-integer ] \ detect-integer inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic assocs hashtables inference kernel
|
||||
math namespaces sequences words parser math.intervals
|
||||
effects classes classes.algebra inference.dataflow
|
||||
inference.backend combinators ;
|
||||
inference.backend combinators accessors ;
|
||||
IN: inference.class
|
||||
|
||||
! Class inference
|
||||
|
|
@ -25,12 +25,10 @@ C: <literal-constraint> literal-constraint
|
|||
|
||||
M: literal-constraint equal?
|
||||
over literal-constraint? [
|
||||
2dup
|
||||
[ literal-constraint-literal ] bi@ eql? >r
|
||||
[ literal-constraint-value ] bi@ = r> and
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
[ [ literal>> ] bi@ eql? ]
|
||||
[ [ value>> ] bi@ = ]
|
||||
2bi and
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
TUPLE: class-constraint class value ;
|
||||
|
||||
|
|
@ -43,8 +41,8 @@ C: <interval-constraint> interval-constraint
|
|||
GENERIC: apply-constraint ( constraint -- )
|
||||
GENERIC: constraint-satisfied? ( constraint -- ? )
|
||||
|
||||
: `input node get node-in-d nth ;
|
||||
: `output node get node-out-d nth ;
|
||||
: `input node get in-d>> nth ;
|
||||
: `output node get out-d>> nth ;
|
||||
: class, <class-constraint> , ;
|
||||
: literal, <literal-constraint> , ;
|
||||
: interval, <interval-constraint> , ;
|
||||
|
|
@ -84,14 +82,12 @@ SYMBOL: value-classes
|
|||
set-value-interval* ;
|
||||
|
||||
M: interval-constraint apply-constraint
|
||||
dup interval-constraint-interval
|
||||
swap interval-constraint-value intersect-value-interval ;
|
||||
[ interval>> ] [ value>> ] bi intersect-value-interval ;
|
||||
|
||||
: set-class-interval ( class value -- )
|
||||
over class? [
|
||||
over "interval" word-prop [
|
||||
>r "interval" word-prop r> set-value-interval*
|
||||
] [ 2drop ] if
|
||||
>r "interval" word-prop r> over
|
||||
[ set-value-interval* ] [ 2drop ] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: value-class* ( value -- class )
|
||||
|
|
@ -110,18 +106,21 @@ M: interval-constraint apply-constraint
|
|||
[ value-class* class-and ] keep set-value-class* ;
|
||||
|
||||
M: class-constraint apply-constraint
|
||||
dup class-constraint-class
|
||||
swap class-constraint-value intersect-value-class ;
|
||||
[ class>> ] [ value>> ] bi intersect-value-class ;
|
||||
|
||||
: literal-interval ( value -- interval/f )
|
||||
dup real? [ [a,a] ] [ drop f ] if ;
|
||||
|
||||
: set-value-literal* ( literal value -- )
|
||||
over class over set-value-class*
|
||||
over real? [ over [a,a] over set-value-interval* ] when
|
||||
2dup <literal-constraint> assume
|
||||
value-literals get set-at ;
|
||||
{
|
||||
[ >r class r> set-value-class* ]
|
||||
[ >r literal-interval r> set-value-interval* ]
|
||||
[ <literal-constraint> assume ]
|
||||
[ value-literals get set-at ]
|
||||
} 2cleave ;
|
||||
|
||||
M: literal-constraint apply-constraint
|
||||
dup literal-constraint-literal
|
||||
swap literal-constraint-value set-value-literal* ;
|
||||
[ literal>> ] [ value>> ] bi set-value-literal* ;
|
||||
|
||||
! For conditionals, an assoc of child node # --> constraint
|
||||
GENERIC: child-constraints ( node -- seq )
|
||||
|
|
@ -133,19 +132,18 @@ GENERIC: infer-classes-around ( node -- )
|
|||
M: node infer-classes-before drop ;
|
||||
|
||||
M: node child-constraints
|
||||
node-children length
|
||||
children>> length
|
||||
dup zero? [ drop f ] [ f <repetition> ] if ;
|
||||
|
||||
: value-literal* ( value -- obj ? )
|
||||
value-literals get at* ;
|
||||
|
||||
M: literal-constraint constraint-satisfied?
|
||||
dup literal-constraint-value value-literal*
|
||||
[ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
|
||||
dup value>> value-literal*
|
||||
[ swap literal>> eql? ] [ 2drop f ] if ;
|
||||
|
||||
M: class-constraint constraint-satisfied?
|
||||
dup class-constraint-value value-class*
|
||||
swap class-constraint-class class< ;
|
||||
[ value>> value-class* ] [ class>> ] bi class< ;
|
||||
|
||||
M: pair apply-constraint
|
||||
first2 2dup constraints get set-at
|
||||
|
|
@ -154,19 +152,18 @@ M: pair apply-constraint
|
|||
M: pair constraint-satisfied?
|
||||
first constraint-satisfied? ;
|
||||
|
||||
: extract-keys ( assoc seq -- newassoc )
|
||||
dup length <hashtable> swap [
|
||||
dup >r pick at* [ r> pick set-at ] [ r> 2drop ] if
|
||||
] each nip f assoc-like ;
|
||||
: extract-keys ( seq assoc -- newassoc )
|
||||
[ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ;
|
||||
|
||||
: annotate-node ( node -- )
|
||||
#! Annotate the node with the currently-inferred set of
|
||||
#! value classes.
|
||||
dup node-values
|
||||
value-intervals get over extract-keys pick set-node-intervals
|
||||
value-classes get over extract-keys pick set-node-classes
|
||||
value-literals get over extract-keys pick set-node-literals
|
||||
2drop ;
|
||||
dup node-values {
|
||||
[ value-intervals get extract-keys >>intervals ]
|
||||
[ value-classes get extract-keys >>classes ]
|
||||
[ value-literals get extract-keys >>literals ]
|
||||
[ 2drop ]
|
||||
} cleave ;
|
||||
|
||||
: intersect-classes ( classes values -- )
|
||||
[ intersect-value-class ] 2each ;
|
||||
|
|
@ -190,31 +187,29 @@ M: pair constraint-satisfied?
|
|||
] 2bi ;
|
||||
|
||||
: compute-constraints ( #call -- )
|
||||
dup node-param "constraints" word-prop [
|
||||
dup param>> "constraints" word-prop [
|
||||
call
|
||||
] [
|
||||
dup node-param "predicating" word-prop dup
|
||||
dup param>> "predicating" word-prop dup
|
||||
[ swap predicate-constraints ] [ 2drop ] if
|
||||
] if* ;
|
||||
|
||||
: compute-output-classes ( node word -- classes intervals )
|
||||
dup node-param "output-classes" word-prop
|
||||
dup param>> "output-classes" word-prop
|
||||
dup [ call ] [ 2drop f f ] if ;
|
||||
|
||||
: output-classes ( node -- classes intervals )
|
||||
dup compute-output-classes >r
|
||||
[ ] [ node-param "default-output-classes" word-prop ] ?if
|
||||
[ ] [ param>> "default-output-classes" word-prop ] ?if
|
||||
r> ;
|
||||
|
||||
M: #call infer-classes-before
|
||||
dup compute-constraints
|
||||
dup node-out-d swap output-classes
|
||||
>r over intersect-classes
|
||||
r> swap intersect-intervals ;
|
||||
[ compute-constraints ] keep
|
||||
[ output-classes ] [ out-d>> ] bi
|
||||
tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
|
||||
|
||||
M: #push infer-classes-before
|
||||
node-out-d
|
||||
[ [ value-literal ] keep set-value-literal* ] each ;
|
||||
out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
|
||||
|
||||
M: #if child-constraints
|
||||
[
|
||||
|
|
@ -224,19 +219,17 @@ M: #if child-constraints
|
|||
|
||||
M: #dispatch child-constraints
|
||||
dup [
|
||||
node-children length [
|
||||
0 `input literal,
|
||||
] each
|
||||
children>> length [ 0 `input literal, ] each
|
||||
] make-constraints ;
|
||||
|
||||
M: #declare infer-classes-before
|
||||
dup node-param swap node-in-d
|
||||
[ param>> ] [ in-d>> ] bi
|
||||
[ intersect-value-class ] 2each ;
|
||||
|
||||
DEFER: (infer-classes)
|
||||
|
||||
: infer-children ( node -- )
|
||||
dup node-children swap child-constraints [
|
||||
[ children>> ] [ child-constraints ] bi [
|
||||
[
|
||||
value-classes [ clone ] change
|
||||
value-literals [ clone ] change
|
||||
|
|
@ -251,17 +244,21 @@ DEFER: (infer-classes)
|
|||
>r dup [ length ] map supremum r> [ pad-left ] 2curry map ;
|
||||
|
||||
: (merge-classes) ( nodes -- seq )
|
||||
[ node-input-classes ] map
|
||||
null pad-all flip [ null [ class-or ] reduce ] map ;
|
||||
dup length 1 = [
|
||||
first node-input-classes
|
||||
] [
|
||||
[ node-input-classes ] map null pad-all flip
|
||||
[ null [ class-or ] reduce ] map
|
||||
] if ;
|
||||
|
||||
: set-classes ( seq node -- )
|
||||
node-out-d [ set-value-class* ] 2reverse-each ;
|
||||
out-d>> [ set-value-class* ] 2reverse-each ;
|
||||
|
||||
: merge-classes ( nodes node -- )
|
||||
>r (merge-classes) r> set-classes ;
|
||||
|
||||
: set-intervals ( seq node -- )
|
||||
node-out-d [ set-value-interval* ] 2reverse-each ;
|
||||
out-d>> [ set-value-interval* ] 2reverse-each ;
|
||||
|
||||
: merge-intervals ( nodes node -- )
|
||||
>r
|
||||
|
|
@ -276,28 +273,70 @@ DEFER: (infer-classes)
|
|||
dup node-successor dup #merge? [
|
||||
swap active-children dup empty?
|
||||
[ 2drop ] [ swap annotate-merge ] if
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: classes= ( inferred current -- ? )
|
||||
2dup min-length [ tail* ] curry bi@ sequence= ;
|
||||
|
||||
SYMBOL: fixed-point?
|
||||
|
||||
SYMBOL: nested-labels
|
||||
|
||||
: annotate-entry ( nodes #label -- )
|
||||
node-child merge-classes ;
|
||||
>r (merge-classes) r> 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 infer-classes-before ( #label -- )
|
||||
#! First, infer types under the hypothesis which hold on
|
||||
#! entry to the recursive label.
|
||||
[ 1array ] keep annotate-entry ;
|
||||
[ init-recursive-calls ]
|
||||
[ [ 1array ] keep annotate-entry ] bi ;
|
||||
|
||||
: infer-label-loop ( #label -- )
|
||||
fixed-point? on
|
||||
dup node-child (infer-classes)
|
||||
dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
|
||||
fixed-point? get [ drop ] [ infer-label-loop ] if ;
|
||||
|
||||
M: #label infer-classes-around ( #label -- )
|
||||
#! Now merge the types at every recursion point with the
|
||||
#! entry types.
|
||||
{
|
||||
[ annotate-node ]
|
||||
[ infer-classes-before ]
|
||||
[ infer-children ]
|
||||
[ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
|
||||
[ node-child (infer-classes) ]
|
||||
} cleave ;
|
||||
[
|
||||
{
|
||||
[ nested-labels get push ]
|
||||
[ annotate-node ]
|
||||
[ infer-classes-before ]
|
||||
[ infer-label-loop ]
|
||||
[ drop nested-labels get pop* ]
|
||||
} cleave
|
||||
] with-scope ;
|
||||
|
||||
: find-label ( param -- #label )
|
||||
param>> nested-labels get [ param>> eq? ] with find nip ;
|
||||
|
||||
M: #call-label infer-classes-before ( #call-label -- )
|
||||
[ find-label returns>> (merge-classes) ] [ out-d>> ] bi
|
||||
[ set-value-class* ] 2each ;
|
||||
|
||||
M: #return infer-classes-around
|
||||
nested-labels get length 0 > [
|
||||
dup param>> nested-labels get peek param>> eq? [
|
||||
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
|
||||
classes= [
|
||||
drop
|
||||
] [
|
||||
fixed-point? off
|
||||
[ in-d>> value-classes get extract-keys ] keep
|
||||
set-node-classes
|
||||
] if
|
||||
] [ drop ] if
|
||||
] [ drop ] if ;
|
||||
|
||||
M: object infer-classes-around
|
||||
{
|
||||
|
|
@ -310,11 +349,13 @@ M: object infer-classes-around
|
|||
: (infer-classes) ( node -- )
|
||||
[
|
||||
[ infer-classes-around ]
|
||||
[ node-successor (infer-classes) ] bi
|
||||
[ node-successor ] bi
|
||||
(infer-classes)
|
||||
] when* ;
|
||||
|
||||
: infer-classes-with ( node classes literals intervals -- )
|
||||
[
|
||||
V{ } clone nested-labels set
|
||||
H{ } assoc-like value-intervals set
|
||||
H{ } assoc-like value-literals set
|
||||
H{ } assoc-like value-classes set
|
||||
|
|
@ -322,13 +363,11 @@ M: object infer-classes-around
|
|||
(infer-classes)
|
||||
] with-scope ;
|
||||
|
||||
: infer-classes ( node -- )
|
||||
f f f infer-classes-with ;
|
||||
: infer-classes ( node -- node )
|
||||
dup f f f infer-classes-with ;
|
||||
|
||||
: infer-classes/node ( node existing -- )
|
||||
#! Infer classes, using the existing node's class info as a
|
||||
#! starting point.
|
||||
dup node-classes
|
||||
over node-literals
|
||||
rot node-intervals
|
||||
[ node-classes ] [ node-literals ] [ node-intervals ] tri
|
||||
infer-classes-with ;
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@ M: object flatten-curry , ;
|
|||
|
||||
: node-child node-children first ;
|
||||
|
||||
TUPLE: #label < node word loop? ;
|
||||
TUPLE: #label < node word loop? returns calls ;
|
||||
|
||||
: #label ( word label -- node )
|
||||
\ #label param-node swap >>word ;
|
||||
|
|
@ -290,6 +290,9 @@ SYMBOL: node-stack
|
|||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,10 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: inference.dataflow inference.backend kernel ;
|
||||
IN: optimizer
|
||||
|
||||
: collect-label-infos ( node -- node )
|
||||
dup [
|
||||
dup #label? [ collect-label-info ] [ drop ] if
|
||||
] each-node ;
|
||||
|
||||
|
|
@ -27,22 +27,22 @@ optimizer ;
|
|||
dup [ 1+ loop-test-1 ] [ drop ] if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-1 ] dataflow dup detect-loops
|
||||
[ loop-test-1 ] dataflow detect-loops
|
||||
\ loop-test-1 label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-1 1 2 3 ] dataflow dup detect-loops
|
||||
[ loop-test-1 1 2 3 ] dataflow detect-loops
|
||||
\ loop-test-1 label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ [ loop-test-1 ] each ] dataflow dup detect-loops
|
||||
[ [ loop-test-1 ] each ] dataflow detect-loops
|
||||
\ loop-test-1 label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ [ loop-test-1 ] each ] dataflow dup detect-loops
|
||||
[ [ loop-test-1 ] each ] dataflow detect-loops
|
||||
\ (each-integer) label-is-loop?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -50,7 +50,7 @@ optimizer ;
|
|||
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-2 ] dataflow dup detect-loops
|
||||
[ loop-test-2 ] dataflow detect-loops
|
||||
\ loop-test-2 label-is-not-loop?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -58,7 +58,7 @@ optimizer ;
|
|||
dup [ [ loop-test-3 ] each ] [ drop ] if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-3 ] dataflow dup detect-loops
|
||||
[ loop-test-3 ] dataflow detect-loops
|
||||
\ loop-test-3 label-is-not-loop?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -73,7 +73,7 @@ optimizer ;
|
|||
dup #label? [ node-successor find-label ] unless ;
|
||||
|
||||
: test-loop-exits
|
||||
dataflow dup detect-loops find-label
|
||||
dataflow detect-loops find-label
|
||||
dup node-param swap
|
||||
[ node-child find-tail find-loop-exits [ class ] map ] keep
|
||||
#label-loop? ;
|
||||
|
|
@ -113,7 +113,7 @@ optimizer ;
|
|||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ [ [ ] map ] map ] dataflow dup detect-loops
|
||||
[ [ [ ] map ] map ] dataflow detect-loops
|
||||
[ dup #label? swap #loop? not and ] node-exists?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -128,22 +128,22 @@ DEFER: a
|
|||
blah [ b ] [ a ] if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ a ] dataflow dup detect-loops
|
||||
[ a ] dataflow detect-loops
|
||||
\ a label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ a ] dataflow dup detect-loops
|
||||
[ a ] dataflow detect-loops
|
||||
\ b label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ b ] dataflow dup detect-loops
|
||||
[ b ] dataflow detect-loops
|
||||
\ a label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ a ] dataflow dup detect-loops
|
||||
[ a ] dataflow detect-loops
|
||||
\ b label-is-loop?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -156,12 +156,12 @@ DEFER: a'
|
|||
blah [ b' ] [ a' ] if ; inline
|
||||
|
||||
[ f ] [
|
||||
[ a' ] dataflow dup detect-loops
|
||||
[ a' ] dataflow detect-loops
|
||||
\ a' label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ b' ] dataflow dup detect-loops
|
||||
[ b' ] dataflow detect-loops
|
||||
\ b' label-is-loop?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -171,11 +171,11 @@ DEFER: a'
|
|||
! a standard iterative dataflow problem after all -- so I'm
|
||||
! tempted to believe the computer here
|
||||
[ t ] [
|
||||
[ b' ] dataflow dup detect-loops
|
||||
[ b' ] dataflow detect-loops
|
||||
\ a' label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ a' ] dataflow dup detect-loops
|
||||
[ a' ] dataflow detect-loops
|
||||
\ b' label-is-loop?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -109,8 +109,9 @@ SYMBOL: potential-loops
|
|||
] [ 2drop ] if
|
||||
] assoc-each [ remove-non-loop-calls ] when ;
|
||||
|
||||
: detect-loops ( nodes -- )
|
||||
: detect-loops ( node -- node )
|
||||
[
|
||||
dup
|
||||
collect-label-info
|
||||
remove-non-tail-calls
|
||||
remove-non-loop-calls
|
||||
|
|
|
|||
|
|
@ -3,12 +3,12 @@ USING: inference inference.dataflow optimizer optimizer.def-use
|
|||
namespaces assocs kernel sequences math tools.test words ;
|
||||
|
||||
[ 3 { 1 1 1 } ] [
|
||||
[ 1 2 3 ] dataflow compute-def-use
|
||||
[ 1 2 3 ] dataflow compute-def-use drop
|
||||
def-use get values dup length swap [ length ] map
|
||||
] unit-test
|
||||
|
||||
: kill-set ( quot -- seq )
|
||||
dataflow compute-def-use compute-dead-literals keys
|
||||
dataflow compute-def-use drop compute-dead-literals keys
|
||||
[ value-literal ] map ;
|
||||
|
||||
: subset? [ member? ] curry all? ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: optimizer.def-use
|
||||
USING: namespaces assocs sequences inference.dataflow
|
||||
inference.backend kernel generic assocs classes vectors ;
|
||||
inference.backend kernel generic assocs classes vectors
|
||||
accessors combinators ;
|
||||
IN: optimizer.def-use
|
||||
|
||||
SYMBOL: def-use
|
||||
|
||||
|
|
@ -21,17 +22,20 @@ SYMBOL: def-use
|
|||
|
||||
GENERIC: node-def-use ( node -- )
|
||||
|
||||
: compute-def-use ( node -- )
|
||||
H{ } clone def-use set [ node-def-use ] each-node ;
|
||||
: compute-def-use ( node -- node )
|
||||
H{ } clone def-use set
|
||||
dup [ node-def-use ] each-node ;
|
||||
|
||||
: nest-def-use ( node -- def-use )
|
||||
[ compute-def-use def-use get ] with-scope ;
|
||||
[ compute-def-use drop def-use get ] with-scope ;
|
||||
|
||||
: (node-def-use) ( node -- )
|
||||
dup dup node-in-d uses-values
|
||||
dup dup node-in-r uses-values
|
||||
dup node-out-d defs-values
|
||||
node-out-r defs-values ;
|
||||
{
|
||||
[ dup in-d>> uses-values ]
|
||||
[ dup in-r>> uses-values ]
|
||||
[ out-d>> defs-values ]
|
||||
[ out-r>> defs-values ]
|
||||
} cleave ;
|
||||
|
||||
M: object node-def-use (node-def-use) ;
|
||||
|
||||
|
|
@ -43,7 +47,7 @@ M: #passthru node-def-use drop ;
|
|||
|
||||
M: #return node-def-use
|
||||
#! Values returned by local labels can be killed.
|
||||
dup node-param [ drop ] [ (node-def-use) ] if ;
|
||||
dup param>> [ drop ] [ (node-def-use) ] if ;
|
||||
|
||||
! nodes that don't use their values directly
|
||||
UNION: #killable
|
||||
|
|
@ -56,13 +60,13 @@ UNION: #killable
|
|||
|
||||
M: #label node-def-use
|
||||
[
|
||||
dup node-in-d ,
|
||||
dup node-child node-out-d ,
|
||||
dup collect-recursion [ node-in-d , ] each
|
||||
dup in-d>> ,
|
||||
dup node-child out-d>> ,
|
||||
dup calls>> [ in-d>> , ] each
|
||||
] { } make purge-invariants uses-values ;
|
||||
|
||||
: branch-def-use ( #branch -- )
|
||||
active-children [ node-in-d ] map
|
||||
active-children [ in-d>> ] map
|
||||
purge-invariants t swap uses-values ;
|
||||
|
||||
M: #branch node-def-use
|
||||
|
|
@ -85,16 +89,16 @@ M: node kill-node* drop t ;
|
|||
inline
|
||||
|
||||
M: #shuffle kill-node*
|
||||
[
|
||||
dup node-in-d empty? swap node-out-d empty? and
|
||||
] prune-if ;
|
||||
[ [ in-d>> empty? ] [ out-d>> empty? ] bi and ] prune-if ;
|
||||
|
||||
M: #push kill-node*
|
||||
[ node-out-d empty? ] prune-if ;
|
||||
[ out-d>> empty? ] prune-if ;
|
||||
|
||||
M: #>r kill-node* [ node-in-d empty? ] prune-if ;
|
||||
M: #>r kill-node*
|
||||
[ in-d>> empty? ] prune-if ;
|
||||
|
||||
M: #r> kill-node* [ node-in-r empty? ] prune-if ;
|
||||
M: #r> kill-node*
|
||||
[ in-r>> empty? ] prune-if ;
|
||||
|
||||
: kill-node ( node -- node )
|
||||
dup [
|
||||
|
|
@ -116,7 +120,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
|
|||
] if ;
|
||||
|
||||
: sole-consumer ( #call -- node/f )
|
||||
node-out-d first used-by
|
||||
out-d>> first used-by
|
||||
dup length 1 = [ first ] [ drop f ] if ;
|
||||
|
||||
: splice-def-use ( node -- )
|
||||
|
|
@ -128,5 +132,5 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
|
|||
#! degree of accuracy; the new values should be marked as
|
||||
#! having _some_ usage, so that flushing doesn't erronously
|
||||
#! flush them away.
|
||||
[ compute-def-use def-use get keys ] with-scope
|
||||
nest-def-use keys
|
||||
def-use get [ [ t swap ?push ] change-at ] curry each ;
|
||||
|
|
|
|||
|
|
@ -71,6 +71,7 @@ DEFER: (flat-length)
|
|||
! Partial dispatch of math-generic words
|
||||
: normalize-math-class ( class -- class' )
|
||||
{
|
||||
null
|
||||
fixnum bignum integer
|
||||
ratio rational
|
||||
float real
|
||||
|
|
@ -192,7 +193,7 @@ DEFER: (flat-length)
|
|||
nip dup [ second ] when ;
|
||||
|
||||
: apply-identities ( node -- node/f )
|
||||
dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
|
||||
dup find-identity f splice-quot ;
|
||||
|
||||
: optimistic-inline? ( #call -- ? )
|
||||
dup node-param "specializer" word-prop dup [
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ namespaces assocs quotations math.intervals sequences.private
|
|||
combinators splitting layouts math.parser classes
|
||||
classes.algebra generic.math optimizer.pattern-match
|
||||
optimizer.backend optimizer.def-use optimizer.inlining
|
||||
optimizer.math.partial generic.standard system ;
|
||||
optimizer.math.partial generic.standard system accessors ;
|
||||
|
||||
: define-math-identities ( word identities -- )
|
||||
>r all-derived-ops r> define-identities ;
|
||||
|
|
@ -95,22 +95,17 @@ optimizer.math.partial generic.standard system ;
|
|||
} define-math-identities
|
||||
|
||||
: math-closure ( class -- newclass )
|
||||
{ fixnum bignum integer rational float real number }
|
||||
{ null fixnum bignum integer rational float real number }
|
||||
[ class< ] with find nip number or ;
|
||||
|
||||
: fits? ( interval class -- ? )
|
||||
"interval" word-prop dup
|
||||
[ interval-subset? ] [ 2drop t ] if ;
|
||||
|
||||
: math-output-class ( node min -- newclass )
|
||||
#! if min is f, it means we just want to use the declared
|
||||
#! output class from the "infer-effect".
|
||||
dup [
|
||||
swap node-in-d
|
||||
[ value-class* math-closure math-class-max ] each
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
: math-output-class ( node upgrades -- newclass )
|
||||
>r
|
||||
in-d>> null [ value-class* math-closure math-class-max ] reduce
|
||||
dup r> at swap or ;
|
||||
|
||||
: won't-overflow? ( interval node -- ? )
|
||||
node-in-d [ value-class* fixnum class< ] all?
|
||||
|
|
@ -129,22 +124,17 @@ optimizer.math.partial generic.standard system ;
|
|||
2drop f
|
||||
] if ; inline
|
||||
|
||||
: math-output-class/interval-1 ( node min word -- classes intervals )
|
||||
pick >r
|
||||
>r over r>
|
||||
math-output-interval-1
|
||||
>r math-output-class r>
|
||||
r> post-process ; inline
|
||||
: math-output-class/interval-1 ( node word -- classes intervals )
|
||||
[ drop { } math-output-class ] [ math-output-interval-1 ] 2bi ;
|
||||
|
||||
{
|
||||
{ bitnot fixnum interval-bitnot }
|
||||
{ fixnum-bitnot f interval-bitnot }
|
||||
{ bignum-bitnot f interval-bitnot }
|
||||
{ bitnot interval-bitnot }
|
||||
{ fixnum-bitnot interval-bitnot }
|
||||
{ bignum-bitnot interval-bitnot }
|
||||
} [
|
||||
first3 [
|
||||
math-output-class/interval-1
|
||||
] 2curry "output-classes" set-word-prop
|
||||
] each
|
||||
[ math-output-class/interval-1 ] curry
|
||||
"output-classes" set-word-prop
|
||||
] assoc-each
|
||||
|
||||
: intervals ( node -- i1 i2 )
|
||||
node-in-d first2 [ value-interval* ] bi@ ;
|
||||
|
|
@ -156,7 +146,7 @@ optimizer.math.partial generic.standard system ;
|
|||
2drop f
|
||||
] if ; inline
|
||||
|
||||
: math-output-class/interval-2 ( node min word -- classes intervals )
|
||||
: math-output-class/interval-2 ( node upgrades word -- classes intervals )
|
||||
pick >r
|
||||
>r over r>
|
||||
math-output-interval-2
|
||||
|
|
@ -164,12 +154,12 @@ optimizer.math.partial generic.standard system ;
|
|||
r> post-process ; inline
|
||||
|
||||
{
|
||||
{ + integer interval+ }
|
||||
{ - integer interval- }
|
||||
{ * integer interval* }
|
||||
{ / rational interval/ }
|
||||
{ /i integer interval/i }
|
||||
{ shift f interval-shift-safe }
|
||||
{ + { { fixnum integer } } interval+ }
|
||||
{ - { { fixnum integer } } interval- }
|
||||
{ * { { fixnum integer } } interval* }
|
||||
{ / { { fixnum rational } { integer rational } } interval/ }
|
||||
{ /i { { fixnum integer } } interval/i }
|
||||
{ shift { { fixnum integer } } interval-shift-safe }
|
||||
} [
|
||||
first3 [
|
||||
[
|
||||
|
|
@ -178,16 +168,6 @@ optimizer.math.partial generic.standard system ;
|
|||
] 2curry each-derived-op
|
||||
] each
|
||||
|
||||
\ shift [
|
||||
[
|
||||
dup
|
||||
node-in-d second value-interval*
|
||||
-1./0. 0 [a,b] interval-subset? fixnum integer ?
|
||||
\ interval-shift-safe
|
||||
math-output-class/interval-2
|
||||
] "output-classes" set-word-prop
|
||||
] each-derived-op
|
||||
|
||||
: real-value? ( value -- n ? )
|
||||
dup value? [ value-literal dup real? ] [ drop f f ] if ;
|
||||
|
||||
|
|
@ -216,12 +196,12 @@ optimizer.math.partial generic.standard system ;
|
|||
r> post-process ; inline
|
||||
|
||||
{
|
||||
{ mod fixnum mod-range }
|
||||
{ rem integer rem-range }
|
||||
{ mod { } mod-range }
|
||||
{ rem { { fixnum integer } } rem-range }
|
||||
|
||||
{ bitand fixnum bitand-range }
|
||||
{ bitor fixnum f }
|
||||
{ bitxor fixnum f }
|
||||
{ bitand { } bitand-range }
|
||||
{ bitor { } f }
|
||||
{ bitxor { } f }
|
||||
} [
|
||||
first3 [
|
||||
[
|
||||
|
|
@ -311,7 +291,8 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
|
||||
! Removing overflow checks
|
||||
: remove-overflow-check? ( #call -- ? )
|
||||
dup node-out-d first node-class fixnum class< ;
|
||||
dup out-d>> first node-class
|
||||
[ fixnum class< ] [ null eq? not ] bi and ;
|
||||
|
||||
{
|
||||
{ + [ fixnum+fast ] }
|
||||
|
|
|
|||
|
|
@ -14,40 +14,6 @@ IN: optimizer.tests
|
|||
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
|
||||
] unit-test
|
||||
|
||||
! Test method inlining
|
||||
[ f ] [ fixnum { } min-class ] unit-test
|
||||
|
||||
[ string ] [
|
||||
\ string
|
||||
[ integer string array reversed sbuf
|
||||
slice vector quotation ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ fixnum ] [
|
||||
\ fixnum
|
||||
[ fixnum integer object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ integer ] [
|
||||
\ fixnum
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ object ] [
|
||||
\ word
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ reversed ] [
|
||||
\ reversed
|
||||
[ integer reversed slice ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
GENERIC: xyz ( obj -- obj )
|
||||
M: array xyz xyz ;
|
||||
|
||||
|
|
@ -374,3 +340,12 @@ HINTS: recursive-inline-hang-3 array ;
|
|||
USE: sequences.private
|
||||
|
||||
[ ] [ { (3append) } compile ] unit-test
|
||||
|
||||
! Wow
|
||||
: counter-example ( a b c d -- a' b' c' d' )
|
||||
dup 0 > [ 1 - >r rot 2 * r> counter-example ] when ; inline
|
||||
|
||||
: counter-example' ( -- a' b' c' d' )
|
||||
1 2 3.0 3 counter-example ;
|
||||
|
||||
[ 2 4 6.0 0 ] [ counter-example' ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces optimizer.backend optimizer.def-use
|
||||
optimizer.known-words optimizer.math optimizer.control
|
||||
optimizer.inlining inference.class ;
|
||||
optimizer.collect optimizer.inlining inference.class ;
|
||||
IN: optimizer
|
||||
|
||||
: optimize-1 ( node -- newnode ? )
|
||||
|
|
@ -10,10 +10,13 @@ IN: optimizer
|
|||
H{ } clone class-substitutions set
|
||||
H{ } clone literal-substitutions set
|
||||
H{ } clone value-substitutions set
|
||||
dup compute-def-use
|
||||
|
||||
collect-label-infos
|
||||
compute-def-use
|
||||
kill-values
|
||||
dup detect-loops
|
||||
dup infer-classes
|
||||
detect-loops
|
||||
infer-classes
|
||||
|
||||
optimizer-changed off
|
||||
optimize-nodes
|
||||
optimizer-changed get
|
||||
|
|
|
|||
Loading…
Reference in New Issue