steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Improve recursive word type inference

db4
Slava Pestov 2008-04-19 02:11:55 -05:00
parent 3b795b6a07
commit 6dedc433d5
14 changed files with 317 additions and 232 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/inference/backend/backend-docs.factor
View File

@ -48,10 +48,6 @@ HELP: no-effect
{ $description "Throws a " { $link no-effect } " error." } { $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." } ; { $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 HELP: inline-word
{ $values { "word" word } } { $values { "word" word } }
{ $description "Called during inference to infer stack effects of inline words." { $description "Called during inference to infer stack effects of inline words."

39
core/inference/backend/backend.factor
View File

@ -409,6 +409,25 @@ TUPLE: recursive-declare-error word ;
\ recursive-declare-error inference-error \ recursive-declare-error inference-error
] if* ; ] 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, ; : nest-node ( -- ) #entry node, ;
: unnest-node ( new-node -- new-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 ; : <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 copy-inference nest-node
dup word-def swap <inlined-block> dup word-def swap <inlined-block>
[ infer-quot-recursive ] 2keep [ infer-quot-recursive ] 2keep
#label unnest-node #label unnest-node
dup collect-label-info
] H{ } make-assoc ; ] H{ } make-assoc ;
GENERIC: collect-recursion* ( label node -- ) : join-values ( #label -- )
calls>> [ node-in-d ] map meta-d get suffix
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
unify-lengths unify-stacks unify-lengths unify-stacks
meta-d [ length tail* ] change ; meta-d [ length tail* ] change ;
@ -460,7 +469,7 @@ M: #call-label collect-recursion*
drop join-values inline-block apply-infer drop join-values inline-block apply-infer
r> over set-node-in-d r> over set-node-in-d
dup node, dup node,
collect-recursion [ calls>> [
[ flatten-curries ] modify-values [ flatten-curries ] modify-values
] each ] each
] [ ] [

79
core/inference/class/class-tests.factor
View File

@ -4,7 +4,12 @@ inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units 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 ! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@ -268,19 +273,24 @@ M: float detect-float ;
[ 3 + = ] \ equal? inlined? [ 3 + = ] \ equal? inlined?
] unit-test ] unit-test
[ t ] [ [ f ] [
[ { fixnum fixnum } declare 7 bitand neg shift ] [ { fixnum fixnum } declare 7 bitand neg shift ]
\ shift inlined? \ fixnum-shift-fast inlined?
] unit-test ] unit-test
[ t ] [ [ t ] [
[ { fixnum fixnum } declare 7 bitand neg shift ] [ { fixnum fixnum } declare 7 bitand neg shift ]
\ fixnum-shift inlined? { shift fixnum-shift } inlined?
] unit-test ] unit-test
[ t ] [ [ t ] [
[ { fixnum fixnum } declare 1 swap 7 bitand shift ] [ { 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 ] unit-test
cell-bits 32 = [ cell-bits 32 = [
@ -375,25 +385,78 @@ cell-bits 32 = [
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test ] unit-test
: rec ( a -- b )
dup 0 > [ 1 - rec ] when ; inline
[ t ] [
[ { fixnum } declare rec 1 + ]
{ > - + } inlined?
] unit-test
: fib ( m -- n ) : fib ( m -- n )
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline
[ t ] [ [ t ] [
[ 27.0 fib ] { < - } inlined? [ 27.0 fib ] { < - + } inlined?
] unit-test
[ f ] [
[ 27.0 fib ] { +-integer-integer } inlined?
] unit-test ] unit-test
[ t ] [ [ t ] [
[ 27 fib ] { < - } inlined? [ 27 fib ] { < - + } inlined?
] unit-test ] unit-test
[ t ] [ [ t ] [
[ 27 >bignum fib ] { < - } inlined? [ 27 >bignum fib ] { < - + } inlined?
] unit-test ] unit-test
[ f ] [ [ f ] [
[ 27/2 fib ] { < - } inlined? [ 27/2 fib ] { < - } inlined?
] unit-test ] 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 ] [ [ t ] [
[ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined? [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
] unit-test ] unit-test

191
core/inference/class/class.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables inference kernel USING: arrays generic assocs hashtables inference kernel
math namespaces sequences words parser math.intervals math namespaces sequences words parser math.intervals
effects classes classes.algebra inference.dataflow effects classes classes.algebra inference.dataflow
inference.backend combinators ; inference.backend combinators accessors ;
IN: inference.class IN: inference.class
! Class inference ! Class inference
@ -25,12 +25,10 @@ C: <literal-constraint> literal-constraint
M: literal-constraint equal? M: literal-constraint equal?
over literal-constraint? [ over literal-constraint? [
2dup [ [ literal>> ] bi@ eql? ]
[ literal-constraint-literal ] bi@ eql? >r [ [ value>> ] bi@ = ]
[ literal-constraint-value ] bi@ = r> and 2bi and
] [ ] [ 2drop f ] if ;
2drop f
] if ;
TUPLE: class-constraint class value ; TUPLE: class-constraint class value ;
@ -43,8 +41,8 @@ C: <interval-constraint> interval-constraint
GENERIC: apply-constraint ( constraint -- ) GENERIC: apply-constraint ( constraint -- )
GENERIC: constraint-satisfied? ( constraint -- ? ) GENERIC: constraint-satisfied? ( constraint -- ? )
: `input node get node-in-d nth ; : `input node get in-d>> nth ;
: `output node get node-out-d nth ; : `output node get out-d>> nth ;
: class, <class-constraint> , ; : class, <class-constraint> , ;
: literal, <literal-constraint> , ; : literal, <literal-constraint> , ;
: interval, <interval-constraint> , ; : interval, <interval-constraint> , ;
@ -84,14 +82,12 @@ SYMBOL: value-classes
set-value-interval* ; set-value-interval* ;
M: interval-constraint apply-constraint M: interval-constraint apply-constraint
dup interval-constraint-interval [ interval>> ] [ value>> ] bi intersect-value-interval ;
swap interval-constraint-value intersect-value-interval ;
: set-class-interval ( class value -- ) : set-class-interval ( class value -- )
over class? [ over class? [
over "interval" word-prop [ >r "interval" word-prop r> over
>r "interval" word-prop r> set-value-interval* [ set-value-interval* ] [ 2drop ] if
] [ 2drop ] if
] [ 2drop ] if ; ] [ 2drop ] if ;
: value-class* ( value -- class ) : value-class* ( value -- class )
@ -110,18 +106,21 @@ M: interval-constraint apply-constraint
[ value-class* class-and ] keep set-value-class* ; [ value-class* class-and ] keep set-value-class* ;
M: class-constraint apply-constraint M: class-constraint apply-constraint
dup class-constraint-class [ class>> ] [ value>> ] bi intersect-value-class ;
swap class-constraint-value intersect-value-class ;
: literal-interval ( value -- interval/f )
dup real? [ [a,a] ] [ drop f ] if ;
: set-value-literal* ( literal value -- ) : set-value-literal* ( literal value -- )
over class over set-value-class* {
over real? [ over [a,a] over set-value-interval* ] when [ >r class r> set-value-class* ]
2dup <literal-constraint> assume [ >r literal-interval r> set-value-interval* ]
value-literals get set-at ; [ <literal-constraint> assume ]
[ value-literals get set-at ]
} 2cleave ;
M: literal-constraint apply-constraint M: literal-constraint apply-constraint
dup literal-constraint-literal [ literal>> ] [ value>> ] bi set-value-literal* ;
swap literal-constraint-value set-value-literal* ;
! For conditionals, an assoc of child node # --> constraint ! For conditionals, an assoc of child node # --> constraint
GENERIC: child-constraints ( node -- seq ) GENERIC: child-constraints ( node -- seq )
@ -133,19 +132,18 @@ GENERIC: infer-classes-around ( node -- )
M: node infer-classes-before drop ; M: node infer-classes-before drop ;
M: node child-constraints M: node child-constraints
node-children length children>> length
dup zero? [ drop f ] [ f <repetition> ] if ; dup zero? [ drop f ] [ f <repetition> ] if ;
: value-literal* ( value -- obj ? ) : value-literal* ( value -- obj ? )
value-literals get at* ; value-literals get at* ;
M: literal-constraint constraint-satisfied? M: literal-constraint constraint-satisfied?
dup literal-constraint-value value-literal* dup value>> value-literal*
[ swap literal-constraint-literal eql? ] [ 2drop f ] if ; [ swap literal>> eql? ] [ 2drop f ] if ;
M: class-constraint constraint-satisfied? M: class-constraint constraint-satisfied?
dup class-constraint-value value-class* [ value>> value-class* ] [ class>> ] bi class< ;
swap class-constraint-class class< ;
M: pair apply-constraint M: pair apply-constraint
first2 2dup constraints get set-at first2 2dup constraints get set-at
@ -154,19 +152,18 @@ M: pair apply-constraint
M: pair constraint-satisfied? M: pair constraint-satisfied?
first constraint-satisfied? ; first constraint-satisfied? ;
: extract-keys ( assoc seq -- newassoc ) : extract-keys ( seq assoc -- newassoc )
dup length <hashtable> swap [ [ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ;
dup >r pick at* [ r> pick set-at ] [ r> 2drop ] if
] each nip f assoc-like ;
: annotate-node ( node -- ) : annotate-node ( node -- )
#! Annotate the node with the currently-inferred set of #! Annotate the node with the currently-inferred set of
#! value classes. #! value classes.
dup node-values dup node-values {
value-intervals get over extract-keys pick set-node-intervals [ value-intervals get extract-keys >>intervals ]
value-classes get over extract-keys pick set-node-classes [ value-classes get extract-keys >>classes ]
value-literals get over extract-keys pick set-node-literals [ value-literals get extract-keys >>literals ]
2drop ; [ 2drop ]
} cleave ;
: intersect-classes ( classes values -- ) : intersect-classes ( classes values -- )
[ intersect-value-class ] 2each ; [ intersect-value-class ] 2each ;
@ -190,31 +187,29 @@ M: pair constraint-satisfied?
] 2bi ; ] 2bi ;
: compute-constraints ( #call -- ) : compute-constraints ( #call -- )
dup node-param "constraints" word-prop [ dup param>> "constraints" word-prop [
call call
] [ ] [
dup node-param "predicating" word-prop dup dup param>> "predicating" word-prop dup
[ swap predicate-constraints ] [ 2drop ] if [ swap predicate-constraints ] [ 2drop ] if
] if* ; ] if* ;
: compute-output-classes ( node word -- classes intervals ) : 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 ; dup [ call ] [ 2drop f f ] if ;
: output-classes ( node -- classes intervals ) : output-classes ( node -- classes intervals )
dup compute-output-classes >r dup compute-output-classes >r
[ ] [ node-param "default-output-classes" word-prop ] ?if [ ] [ param>> "default-output-classes" word-prop ] ?if
r> ; r> ;
M: #call infer-classes-before M: #call infer-classes-before
dup compute-constraints [ compute-constraints ] keep
dup node-out-d swap output-classes [ output-classes ] [ out-d>> ] bi
>r over intersect-classes tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
r> swap intersect-intervals ;
M: #push infer-classes-before M: #push infer-classes-before
node-out-d out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
[ [ value-literal ] keep set-value-literal* ] each ;
M: #if child-constraints M: #if child-constraints
[ [
@ -224,19 +219,17 @@ M: #if child-constraints
M: #dispatch child-constraints M: #dispatch child-constraints
dup [ dup [
node-children length [ children>> length [ 0 `input literal, ] each
0 `input literal,
] each
] make-constraints ; ] make-constraints ;
M: #declare infer-classes-before M: #declare infer-classes-before
dup node-param swap node-in-d [ param>> ] [ in-d>> ] bi
[ intersect-value-class ] 2each ; [ intersect-value-class ] 2each ;
DEFER: (infer-classes) DEFER: (infer-classes)
: infer-children ( node -- ) : infer-children ( node -- )
dup node-children swap child-constraints [ [ children>> ] [ child-constraints ] bi [
[ [
value-classes [ clone ] change value-classes [ clone ] change
value-literals [ clone ] change value-literals [ clone ] change
@ -251,17 +244,21 @@ DEFER: (infer-classes)
>r dup [ length ] map supremum r> [ pad-left ] 2curry map ; >r dup [ length ] map supremum r> [ pad-left ] 2curry map ;
: (merge-classes) ( nodes -- seq ) : (merge-classes) ( nodes -- seq )
[ node-input-classes ] map dup length 1 = [
null pad-all flip [ null [ class-or ] reduce ] map ; first node-input-classes
] [
[ node-input-classes ] map null pad-all flip
[ null [ class-or ] reduce ] map
] if ;
: set-classes ( seq node -- ) : set-classes ( seq node -- )
node-out-d [ set-value-class* ] 2reverse-each ; out-d>> [ set-value-class* ] 2reverse-each ;
: merge-classes ( nodes node -- ) : merge-classes ( nodes node -- )
>r (merge-classes) r> set-classes ; >r (merge-classes) r> set-classes ;
: set-intervals ( seq node -- ) : set-intervals ( seq node -- )
node-out-d [ set-value-interval* ] 2reverse-each ; out-d>> [ set-value-interval* ] 2reverse-each ;
: merge-intervals ( nodes node -- ) : merge-intervals ( nodes node -- )
>r >r
@ -276,28 +273,70 @@ DEFER: (infer-classes)
dup node-successor dup #merge? [ dup node-successor dup #merge? [
swap active-children dup empty? swap active-children dup empty?
[ 2drop ] [ swap annotate-merge ] if [ 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 -- ) : 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 -- ) M: #label infer-classes-before ( #label -- )
#! First, infer types under the hypothesis which hold on [ init-recursive-calls ]
#! entry to the recursive label. [ [ 1array ] keep annotate-entry ] bi ;
[ 1array ] keep annotate-entry ;
: 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 -- ) M: #label infer-classes-around ( #label -- )
#! Now merge the types at every recursion point with the #! Now merge the types at every recursion point with the
#! entry types. #! entry types.
{ [
[ annotate-node ] {
[ infer-classes-before ] [ nested-labels get push ]
[ infer-children ] [ annotate-node ]
[ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ] [ infer-classes-before ]
[ node-child (infer-classes) ] [ infer-label-loop ]
} cleave ; [ 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 M: object infer-classes-around
{ {
@ -310,11 +349,13 @@ M: object infer-classes-around
: (infer-classes) ( node -- ) : (infer-classes) ( node -- )
[ [
[ infer-classes-around ] [ infer-classes-around ]
[ node-successor (infer-classes) ] bi [ node-successor ] bi
(infer-classes)
] when* ; ] when* ;
: infer-classes-with ( node classes literals intervals -- ) : infer-classes-with ( node classes literals intervals -- )
[ [
V{ } clone nested-labels set
H{ } assoc-like value-intervals set H{ } assoc-like value-intervals set
H{ } assoc-like value-literals set H{ } assoc-like value-literals set
H{ } assoc-like value-classes set H{ } assoc-like value-classes set
@ -322,13 +363,11 @@ M: object infer-classes-around
(infer-classes) (infer-classes)
] with-scope ; ] with-scope ;
: infer-classes ( node -- ) : infer-classes ( node -- node )
f f f infer-classes-with ; dup f f f infer-classes-with ;
: infer-classes/node ( node existing -- ) : infer-classes/node ( node existing -- )
#! Infer classes, using the existing node's class info as a #! Infer classes, using the existing node's class info as a
#! starting point. #! starting point.
dup node-classes [ node-classes ] [ node-literals ] [ node-intervals ] tri
over node-literals
rot node-intervals
infer-classes-with ; infer-classes-with ;

5
core/inference/dataflow/dataflow.factor
View File

@ -90,7 +90,7 @@ M: object flatten-curry , ;
: node-child node-children first ; : node-child node-children first ;
TUPLE: #label < node word loop? ; TUPLE: #label < node word loop? returns calls ;
: #label ( word label -- node ) : #label ( word label -- node )
\ #label param-node swap >>word ; \ #label param-node swap >>word ;
@ -290,6 +290,9 @@ SYMBOL: node-stack
: node-input-classes ( node -- seq ) : node-input-classes ( node -- seq )
dup in-d>> [ node-class ] with map ; dup in-d>> [ node-class ] with map ;
: node-output-classes ( node -- seq )
dup out-d>> [ node-class ] with map ;
: node-input-intervals ( node -- seq ) : node-input-intervals ( node -- seq )
dup in-d>> [ node-interval ] with map ; dup in-d>> [ node-interval ] with map ;

10
core/optimizer/collect/collect.factor Normal file
View File

@ -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 ;

32
core/optimizer/control/control-tests.factor
View File

@ -27,22 +27,22 @@ optimizer ;
dup [ 1+ loop-test-1 ] [ drop ] if ; inline dup [ 1+ loop-test-1 ] [ drop ] if ; inline
[ t ] [ [ t ] [
[ loop-test-1 ] dataflow dup detect-loops [ loop-test-1 ] dataflow detect-loops
\ loop-test-1 label-is-loop? \ loop-test-1 label-is-loop?
] unit-test ] unit-test
[ t ] [ [ 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? \ loop-test-1 label-is-loop?
] unit-test ] unit-test
[ t ] [ [ t ] [
[ [ loop-test-1 ] each ] dataflow dup detect-loops [ [ loop-test-1 ] each ] dataflow detect-loops
\ loop-test-1 label-is-loop? \ loop-test-1 label-is-loop?
] unit-test ] unit-test
[ t ] [ [ t ] [
[ [ loop-test-1 ] each ] dataflow dup detect-loops [ [ loop-test-1 ] each ] dataflow detect-loops
\ (each-integer) label-is-loop? \ (each-integer) label-is-loop?
] unit-test ] unit-test
@ -50,7 +50,7 @@ optimizer ;
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline
[ t ] [ [ t ] [
[ loop-test-2 ] dataflow dup detect-loops [ loop-test-2 ] dataflow detect-loops
\ loop-test-2 label-is-not-loop? \ loop-test-2 label-is-not-loop?
] unit-test ] unit-test
@ -58,7 +58,7 @@ optimizer ;
dup [ [ loop-test-3 ] each ] [ drop ] if ; inline dup [ [ loop-test-3 ] each ] [ drop ] if ; inline
[ t ] [ [ t ] [
[ loop-test-3 ] dataflow dup detect-loops [ loop-test-3 ] dataflow detect-loops
\ loop-test-3 label-is-not-loop? \ loop-test-3 label-is-not-loop?
] unit-test ] unit-test
@ -73,7 +73,7 @@ optimizer ;
dup #label? [ node-successor find-label ] unless ; dup #label? [ node-successor find-label ] unless ;
: test-loop-exits : test-loop-exits
dataflow dup detect-loops find-label dataflow detect-loops find-label
dup node-param swap dup node-param swap
[ node-child find-tail find-loop-exits [ class ] map ] keep [ node-child find-tail find-loop-exits [ class ] map ] keep
#label-loop? ; #label-loop? ;
@ -113,7 +113,7 @@ optimizer ;
] unit-test ] unit-test
[ f ] [ [ f ] [
[ [ [ ] map ] map ] dataflow dup detect-loops [ [ [ ] map ] map ] dataflow detect-loops
[ dup #label? swap #loop? not and ] node-exists? [ dup #label? swap #loop? not and ] node-exists?
] unit-test ] unit-test
@ -128,22 +128,22 @@ DEFER: a
blah [ b ] [ a ] if ; inline blah [ b ] [ a ] if ; inline
[ t ] [ [ t ] [
[ a ] dataflow dup detect-loops [ a ] dataflow detect-loops
\ a label-is-loop? \ a label-is-loop?
] unit-test ] unit-test
[ t ] [ [ t ] [
[ a ] dataflow dup detect-loops [ a ] dataflow detect-loops
\ b label-is-loop? \ b label-is-loop?
] unit-test ] unit-test
[ t ] [ [ t ] [
[ b ] dataflow dup detect-loops [ b ] dataflow detect-loops
\ a label-is-loop? \ a label-is-loop?
] unit-test ] unit-test
[ t ] [ [ t ] [
[ a ] dataflow dup detect-loops [ a ] dataflow detect-loops
\ b label-is-loop? \ b label-is-loop?
] unit-test ] unit-test
@ -156,12 +156,12 @@ DEFER: a'
blah [ b' ] [ a' ] if ; inline blah [ b' ] [ a' ] if ; inline
[ f ] [ [ f ] [
[ a' ] dataflow dup detect-loops [ a' ] dataflow detect-loops
\ a' label-is-loop? \ a' label-is-loop?
] unit-test ] unit-test
[ f ] [ [ f ] [
[ b' ] dataflow dup detect-loops [ b' ] dataflow detect-loops
\ b' label-is-loop? \ b' label-is-loop?
] unit-test ] unit-test
@ -171,11 +171,11 @@ DEFER: a'
! a standard iterative dataflow problem after all -- so I'm ! a standard iterative dataflow problem after all -- so I'm
! tempted to believe the computer here ! tempted to believe the computer here
[ t ] [ [ t ] [
[ b' ] dataflow dup detect-loops [ b' ] dataflow detect-loops
\ a' label-is-loop? \ a' label-is-loop?
] unit-test ] unit-test
[ f ] [ [ f ] [
[ a' ] dataflow dup detect-loops [ a' ] dataflow detect-loops
\ b' label-is-loop? \ b' label-is-loop?
] unit-test ] unit-test

3
core/optimizer/control/control.factor
View File

@ -109,8 +109,9 @@ SYMBOL: potential-loops
] [ 2drop ] if ] [ 2drop ] if
] assoc-each [ remove-non-loop-calls ] when ; ] assoc-each [ remove-non-loop-calls ] when ;
: detect-loops ( nodes -- ) : detect-loops ( node -- node )
[ [
dup
collect-label-info collect-label-info
remove-non-tail-calls remove-non-tail-calls
remove-non-loop-calls remove-non-loop-calls

4
core/optimizer/def-use/def-use-tests.factor
View File

@ -3,12 +3,12 @@ USING: inference inference.dataflow optimizer optimizer.def-use
namespaces assocs kernel sequences math tools.test words ; namespaces assocs kernel sequences math tools.test words ;
[ 3 { 1 1 1 } ] [ [ 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 def-use get values dup length swap [ length ] map
] unit-test ] unit-test
: kill-set ( quot -- seq ) : kill-set ( quot -- seq )
dataflow compute-def-use compute-dead-literals keys dataflow compute-def-use drop compute-dead-literals keys
[ value-literal ] map ; [ value-literal ] map ;
: subset? [ member? ] curry all? ; : subset? [ member? ] curry all? ;

50
core/optimizer/def-use/def-use.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.def-use
USING: namespaces assocs sequences inference.dataflow 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 SYMBOL: def-use
@ -21,17 +22,20 @@ SYMBOL: def-use
GENERIC: node-def-use ( node -- ) GENERIC: node-def-use ( node -- )
: compute-def-use ( node -- ) : compute-def-use ( node -- node )
H{ } clone def-use set [ node-def-use ] each-node ; H{ } clone def-use set
dup [ node-def-use ] each-node ;
: nest-def-use ( node -- def-use ) : 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 -- ) : (node-def-use) ( node -- )
dup dup node-in-d uses-values {
dup dup node-in-r uses-values [ dup in-d>> uses-values ]
dup node-out-d defs-values [ dup in-r>> uses-values ]
node-out-r defs-values ; [ out-d>> defs-values ]
[ out-r>> defs-values ]
} cleave ;
M: object node-def-use (node-def-use) ; M: object node-def-use (node-def-use) ;
@ -43,7 +47,7 @@ M: #passthru node-def-use drop ;
M: #return node-def-use M: #return node-def-use
#! Values returned by local labels can be killed. #! 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 ! nodes that don't use their values directly
UNION: #killable UNION: #killable
@ -56,13 +60,13 @@ UNION: #killable
M: #label node-def-use M: #label node-def-use
[ [
dup node-in-d , dup in-d>> ,
dup node-child node-out-d , dup node-child out-d>> ,
dup collect-recursion [ node-in-d , ] each dup calls>> [ in-d>> , ] each
] { } make purge-invariants uses-values ; ] { } make purge-invariants uses-values ;
: branch-def-use ( #branch -- ) : branch-def-use ( #branch -- )
active-children [ node-in-d ] map active-children [ in-d>> ] map
purge-invariants t swap uses-values ; purge-invariants t swap uses-values ;
M: #branch node-def-use M: #branch node-def-use
@ -85,16 +89,16 @@ M: node kill-node* drop t ;
inline inline
M: #shuffle kill-node* M: #shuffle kill-node*
[ [ [ in-d>> empty? ] [ out-d>> empty? ] bi and ] prune-if ;
dup node-in-d empty? swap node-out-d empty? and
] prune-if ;
M: #push kill-node* 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 ) : kill-node ( node -- node )
dup [ dup [
@ -116,7 +120,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
] if ; ] if ;
: sole-consumer ( #call -- node/f ) : sole-consumer ( #call -- node/f )
node-out-d first used-by out-d>> first used-by
dup length 1 = [ first ] [ drop f ] if ; dup length 1 = [ first ] [ drop f ] if ;
: splice-def-use ( node -- ) : 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 #! degree of accuracy; the new values should be marked as
#! having _some_ usage, so that flushing doesn't erronously #! having _some_ usage, so that flushing doesn't erronously
#! flush them away. #! 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 ; def-use get [ [ t swap ?push ] change-at ] curry each ;

3
core/optimizer/inlining/inlining.factor
View File

@ -71,6 +71,7 @@ DEFER: (flat-length)
! Partial dispatch of math-generic words ! Partial dispatch of math-generic words
: normalize-math-class ( class -- class' ) : normalize-math-class ( class -- class' )
{ {
null
fixnum bignum integer fixnum bignum integer
ratio rational ratio rational
float real float real
@ -192,7 +193,7 @@ DEFER: (flat-length)
nip dup [ second ] when ; nip dup [ second ] when ;
: apply-identities ( node -- node/f ) : apply-identities ( node -- node/f )
dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; dup find-identity f splice-quot ;
: optimistic-inline? ( #call -- ? ) : optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [ dup node-param "specializer" word-prop dup [

75
core/optimizer/math/math.factor
View File

@ -8,7 +8,7 @@ namespaces assocs quotations math.intervals sequences.private
combinators splitting layouts math.parser classes combinators splitting layouts math.parser classes
classes.algebra generic.math optimizer.pattern-match classes.algebra generic.math optimizer.pattern-match
optimizer.backend optimizer.def-use optimizer.inlining 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 -- ) : define-math-identities ( word identities -- )
>r all-derived-ops r> define-identities ; >r all-derived-ops r> define-identities ;
@ -95,22 +95,17 @@ optimizer.math.partial generic.standard system ;
} define-math-identities } define-math-identities
: math-closure ( class -- newclass ) : 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 ; [ class< ] with find nip number or ;
: fits? ( interval class -- ? ) : fits? ( interval class -- ? )
"interval" word-prop dup "interval" word-prop dup
[ interval-subset? ] [ 2drop t ] if ; [ interval-subset? ] [ 2drop t ] if ;
: math-output-class ( node min -- newclass ) : math-output-class ( node upgrades -- newclass )
#! if min is f, it means we just want to use the declared >r
#! output class from the "infer-effect". in-d>> null [ value-class* math-closure math-class-max ] reduce
dup [ dup r> at swap or ;
swap node-in-d
[ value-class* math-closure math-class-max ] each
] [
2drop f
] if ;
: won't-overflow? ( interval node -- ? ) : won't-overflow? ( interval node -- ? )
node-in-d [ value-class* fixnum class< ] all? node-in-d [ value-class* fixnum class< ] all?
@ -129,22 +124,17 @@ optimizer.math.partial generic.standard system ;
2drop f 2drop f
] if ; inline ] if ; inline
: math-output-class/interval-1 ( node min word -- classes intervals ) : math-output-class/interval-1 ( node word -- classes intervals )
pick >r [ drop { } math-output-class ] [ math-output-interval-1 ] 2bi ;
>r over r>
math-output-interval-1
>r math-output-class r>
r> post-process ; inline
{ {
{ bitnot fixnum interval-bitnot } { bitnot interval-bitnot }
{ fixnum-bitnot f interval-bitnot } { fixnum-bitnot interval-bitnot }
{ bignum-bitnot f interval-bitnot } { bignum-bitnot interval-bitnot }
} [ } [
first3 [ [ math-output-class/interval-1 ] curry
math-output-class/interval-1 "output-classes" set-word-prop
] 2curry "output-classes" set-word-prop ] assoc-each
] each
: intervals ( node -- i1 i2 ) : intervals ( node -- i1 i2 )
node-in-d first2 [ value-interval* ] bi@ ; node-in-d first2 [ value-interval* ] bi@ ;
@ -156,7 +146,7 @@ optimizer.math.partial generic.standard system ;
2drop f 2drop f
] if ; inline ] if ; inline
: math-output-class/interval-2 ( node min word -- classes intervals ) : math-output-class/interval-2 ( node upgrades word -- classes intervals )
pick >r pick >r
>r over r> >r over r>
math-output-interval-2 math-output-interval-2
@ -164,12 +154,12 @@ optimizer.math.partial generic.standard system ;
r> post-process ; inline r> post-process ; inline
{ {
{ + integer interval+ } { + { { fixnum integer } } interval+ }
{ - integer interval- } { - { { fixnum integer } } interval- }
{ * integer interval* } { * { { fixnum integer } } interval* }
{ / rational interval/ } { / { { fixnum rational } { integer rational } } interval/ }
{ /i integer interval/i } { /i { { fixnum integer } } interval/i }
{ shift f interval-shift-safe } { shift { { fixnum integer } } interval-shift-safe }
} [ } [
first3 [ first3 [
[ [
@ -178,16 +168,6 @@ optimizer.math.partial generic.standard system ;
] 2curry each-derived-op ] 2curry each-derived-op
] each ] 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 ? ) : real-value? ( value -- n ? )
dup value? [ value-literal dup real? ] [ drop f f ] if ; dup value? [ value-literal dup real? ] [ drop f f ] if ;
@ -216,12 +196,12 @@ optimizer.math.partial generic.standard system ;
r> post-process ; inline r> post-process ; inline
{ {
{ mod fixnum mod-range } { mod { } mod-range }
{ rem integer rem-range } { rem { { fixnum integer } } rem-range }
{ bitand fixnum bitand-range } { bitand { } bitand-range }
{ bitor fixnum f } { bitor { } f }
{ bitxor fixnum f } { bitxor { } f }
} [ } [
first3 [ first3 [
[ [
@ -311,7 +291,8 @@ most-negative-fixnum most-positive-fixnum [a,b]
! Removing overflow checks ! Removing overflow checks
: remove-overflow-check? ( #call -- ? ) : 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 ] } { + [ fixnum+fast ] }

43
core/optimizer/optimizer-tests.factor
View File

@ -14,40 +14,6 @@ IN: optimizer.tests
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
] unit-test ] 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 ) GENERIC: xyz ( obj -- obj )
M: array xyz xyz ; M: array xyz xyz ;
@ -374,3 +340,12 @@ HINTS: recursive-inline-hang-3 array ;
USE: sequences.private USE: sequences.private
[ ] [ { (3append) } compile ] unit-test [ ] [ { (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

11
core/optimizer/optimizer.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces optimizer.backend optimizer.def-use USING: kernel namespaces optimizer.backend optimizer.def-use
optimizer.known-words optimizer.math optimizer.control optimizer.known-words optimizer.math optimizer.control
optimizer.inlining inference.class ; optimizer.collect optimizer.inlining inference.class ;
IN: optimizer IN: optimizer
: optimize-1 ( node -- newnode ? ) : optimize-1 ( node -- newnode ? )
@ -10,10 +10,13 @@ IN: optimizer
H{ } clone class-substitutions set H{ } clone class-substitutions set
H{ } clone literal-substitutions set H{ } clone literal-substitutions set
H{ } clone value-substitutions set H{ } clone value-substitutions set
dup compute-def-use
collect-label-infos
compute-def-use
kill-values kill-values
dup detect-loops detect-loops
dup infer-classes infer-classes
optimizer-changed off optimizer-changed off
optimize-nodes optimize-nodes
optimizer-changed get optimizer-changed get