Propagation now does method inlining; working on cleanup pass
parent
75af228f5a
commit
45c1da32eb
|
@ -23,14 +23,14 @@ $nl
|
|||
{ $subsection specialized-def } ;
|
||||
|
||||
HELP: build-tree
|
||||
{ $values { "quot" quotation } { "dataflow" node } }
|
||||
{ $values { "quot" quotation } { "nodes" "a sequence of nodes" } }
|
||||
{ $description "Attempts to construct tree SSA IR from a quotation." }
|
||||
{ $notes "This is the first stage of the compiler." }
|
||||
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
||||
|
||||
HELP: build-tree-with
|
||||
{ $values { "quot" quotation } { "stack" sequence } { "dataflow" node } }
|
||||
{ $description "Attempts to construct tree SSA IR from a quotaiton, starting with an initial data stack of values." }
|
||||
{ $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } }
|
||||
{ $description "Attempts to construct tree SSA IR from a quotaiton, starting with an initial data stack of values, and outputting stack resulting at the end." }
|
||||
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
||||
|
||||
HELP: specialized-def
|
||||
|
|
|
@ -11,16 +11,16 @@ IN: compiler.tree.builder
|
|||
[ V{ } clone stack-visitor set ] prepose
|
||||
with-infer ; inline
|
||||
|
||||
GENERIC# build-tree-with 1 ( quot stack -- nodes )
|
||||
: build-tree ( quot -- nodes )
|
||||
#! Not safe to call from inference transforms.
|
||||
[ f infer-quot ] with-tree-builder nip ;
|
||||
|
||||
M: callable build-tree-with
|
||||
: build-tree-with ( in-stack quot -- nodes out-stack )
|
||||
#! Not safe to call from inference transforms.
|
||||
[
|
||||
>vector meta-d set
|
||||
f infer-quot
|
||||
] with-tree-builder nip ;
|
||||
|
||||
: build-tree ( quot -- nodes ) f build-tree-with ;
|
||||
[ >vector meta-d set ] [ f infer-quot ] bi*
|
||||
] with-tree-builder nip
|
||||
unclip-last in-d>> ;
|
||||
|
||||
: (make-specializer) ( class picker -- quot )
|
||||
swap "predicate" word-prop append ;
|
||||
|
|
|
@ -0,0 +1,578 @@
|
|||
IN: compiler.tree.cleanup.tests
|
||||
USING: tools.test kernel.private kernel arrays sequences
|
||||
math.private math generic words quotations alien alien.c-types
|
||||
strings sbufs sequences.private slots.private combinators
|
||||
definitions system layouts vectors math.partial-dispatch
|
||||
math.order math.functions accessors hashtables classes assocs
|
||||
io.encodings.utf8 io.encodings.ascii io.encodings fry
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.cleanup
|
||||
compiler.tree.builder
|
||||
compiler.tree.copy-equiv
|
||||
compiler.tree.normalization
|
||||
compiler.tree.propagation ;
|
||||
|
||||
: cleaned-up-tree ( quot -- nodes )
|
||||
build-tree normalize compute-copy-equiv propagate cleanup ;
|
||||
|
||||
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
|
||||
|
||||
[ f ] [ [ f [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
|
||||
|
||||
[ f ] [ [ { array } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
|
||||
|
||||
[ t ] [ [ { sequence } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
|
||||
|
||||
: recursive-test ( a -- b ) dup [ not recursive-test ] when ; inline recursive
|
||||
|
||||
[ t ] [ [ recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
|
||||
|
||||
[ f ] [ [ f recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
|
||||
|
||||
[ t ] [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
|
||||
|
||||
: inlined? ( quot seq/word -- ? )
|
||||
[ cleaned-up-tree ] dip
|
||||
dup word? [ 1array ] when
|
||||
'[ dup #call? [ word>> , member? ] [ drop f ] if ]
|
||||
contains-node? not ;
|
||||
|
||||
[ f ] [
|
||||
[ { integer } declare >fixnum ]
|
||||
\ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
GENERIC: mynot ( x -- y )
|
||||
|
||||
M: f mynot drop t ;
|
||||
|
||||
M: object mynot drop f ;
|
||||
|
||||
GENERIC: detect-f ( x -- y )
|
||||
|
||||
M: f detect-f ;
|
||||
|
||||
[ t ] [
|
||||
[ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
|
||||
] unit-test
|
||||
|
||||
GENERIC: xyz ( n -- n )
|
||||
|
||||
M: integer xyz ;
|
||||
|
||||
M: object xyz ;
|
||||
|
||||
[ t ] [
|
||||
[ { integer } declare xyz ] \ xyz inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ dup fixnum? [ xyz ] [ drop "hi" ] if ]
|
||||
\ xyz inlined?
|
||||
] unit-test
|
||||
|
||||
: (fx-repeat) ( i n quot: ( i -- i ) -- )
|
||||
2over fixnum>= [
|
||||
3drop
|
||||
] [
|
||||
[ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
|
||||
] if ; inline recursive
|
||||
|
||||
: fx-repeat ( n quot -- )
|
||||
0 -rot (fx-repeat) ; inline
|
||||
|
||||
! The + should be optimized into fixnum+, if it was not, then
|
||||
! the type of the loop index was not inferred correctly
|
||||
[ t ] [
|
||||
[ [ dup 2 + drop ] fx-repeat ] \ + inlined?
|
||||
] unit-test
|
||||
|
||||
: (i-repeat) ( i n quot: ( i -- i ) -- )
|
||||
2over dup xyz drop >= [
|
||||
3drop
|
||||
] [
|
||||
[ swap >r call 1+ r> ] keep (i-repeat)
|
||||
] if ; inline recursive
|
||||
|
||||
: i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline
|
||||
|
||||
[ t ] [
|
||||
[ [ dup xyz drop ] i-repeat ] \ xyz inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare dup 100 >= [ 1 + ] unless ] \ fixnum+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
|
||||
\ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
|
||||
\ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ ] times ] \ >= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ ] times ] \ 1+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ ] times ] \ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ ] times ] \ fixnum+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { integer fixnum } declare dupd < [ 1 + ] when ]
|
||||
\ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { integer fixnum } declare dupd < [ 1 + ] when ]
|
||||
\ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
[ no-cond ] 1
|
||||
[ 1array dup quotation? [ >quotation ] unless ] times
|
||||
] \ quotation? inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
1000000000000000000000000000000000 [ ] times
|
||||
] \ + inlined?
|
||||
] unit-test
|
||||
[ f ] [
|
||||
[
|
||||
1000000000000000000000000000000000 [ ] times
|
||||
] \ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { bignum } declare [ ] times ]
|
||||
\ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
|
||||
[ t ] [
|
||||
[ { string sbuf } declare ] \ push-all def>> append \ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { array-capacity } declare 0 < ] \ < inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { array-capacity } declare 0 < ] \ fixnum< inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 5000 [ [ ] times ] each ] \ 1+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
|
||||
\ 1+ inlined?
|
||||
] unit-test
|
||||
|
||||
GENERIC: annotate-entry-test-1 ( x -- )
|
||||
|
||||
M: fixnum annotate-entry-test-1 drop ;
|
||||
|
||||
: (annotate-entry-test-2) ( from to quot: ( -- ) -- )
|
||||
2over >= [
|
||||
3drop
|
||||
] [
|
||||
[ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2)
|
||||
] if ; inline recursive
|
||||
|
||||
: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
|
||||
|
||||
[ f ] [
|
||||
[ { bignum } declare [ ] annotate-entry-test-2 ]
|
||||
\ annotate-entry-test-1 inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { float } declare 10 [ 2.3 * ] times >float ]
|
||||
\ >float inlined?
|
||||
] unit-test
|
||||
|
||||
GENERIC: detect-float ( a -- b )
|
||||
|
||||
M: float detect-float ;
|
||||
|
||||
[ t ] [
|
||||
[ { real float } declare + detect-float ]
|
||||
\ detect-float inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { float real } declare + detect-float ]
|
||||
\ detect-float inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 3 + = ] \ equal? inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum fixnum } declare 7 bitand neg shift ]
|
||||
\ fixnum-shift-fast inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare 7 bitand neg shift ]
|
||||
{ shift fixnum-shift } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
|
||||
{ shift fixnum-shift } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
|
||||
{ fixnum-shift-fast } inlined?
|
||||
] unit-test
|
||||
|
||||
cell-bits 32 = [
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
|
||||
\ shift inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
|
||||
\ fixnum-shift inlined?
|
||||
] unit-test
|
||||
] when
|
||||
|
||||
[ f ] [
|
||||
[ { integer } declare -63 shift 4095 bitand ]
|
||||
\ shift inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short 0 number= ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short 0 { number number } declare number= ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short 0 = ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ HEX: ff bitand 0 HEX: ff between? ]
|
||||
\ >= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ HEX: ff swap HEX: ff bitand >= ]
|
||||
\ >= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
dup integer? [
|
||||
dup fixnum? [
|
||||
1 +
|
||||
] [
|
||||
2 +
|
||||
] if
|
||||
] when
|
||||
] \ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
256 mod
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
dup 0 >= [ 256 mod ] when
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare dup 0 >= [ 256 mod ] when
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare 256 rem
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare [ 256 rem ] map
|
||||
] { mod fixnum-mod rem } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
|
||||
] unit-test
|
||||
|
||||
: rec ( a -- b )
|
||||
dup 0 > [ 1 - rec ] when ; inline recursive
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare rec 1 + ]
|
||||
{ > - + } inlined?
|
||||
] unit-test
|
||||
|
||||
: fib ( m -- n )
|
||||
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline recursive
|
||||
|
||||
[ t ] [
|
||||
[ 27.0 fib ] { < - + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ 27.0 fib ] { +-integer-integer } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 27 fib ] { < - + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 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 recursive
|
||||
|
||||
[ t ] [
|
||||
[ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
|
||||
] { } inlined? ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
|
||||
\ fixnum-bitand inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { integer } declare 127 bitand 3 + ]
|
||||
{ + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { integer } declare 127 bitand 3 + ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ drop ] each-integer ]
|
||||
{ < <-integer-fixnum +-integer-fixnum + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare length [ drop ] each-integer ]
|
||||
{ < <-integer-fixnum +-integer-fixnum + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ drop ] each ]
|
||||
{ < <-integer-fixnum +-integer-fixnum + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare 0 [ + ] reduce ]
|
||||
{ < <-integer-fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum } declare 0 [ + ] reduce ]
|
||||
\ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare
|
||||
dup 0 >= [
|
||||
615949 * 797807 + 20 2^ mod dup 19 2^ -
|
||||
] [ dup ] if
|
||||
] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ fixnum } declare
|
||||
615949 * 797807 + 20 2^ mod dup 19 2^ -
|
||||
] { >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
{ integer } declare [ ] map
|
||||
] \ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
{ integer } declare { } set-nth-unsafe
|
||||
] \ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
{ integer } declare 1 + { } set-nth-unsafe
|
||||
] \ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare 0 swap
|
||||
[
|
||||
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
|
||||
] map
|
||||
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ fixnum } declare 0 swap
|
||||
[
|
||||
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
|
||||
] map
|
||||
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ hashtable new ] \ new inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ dup hashtable eq? [ new ] when ] \ new inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { hashtable } declare hashtable instance? ] \ instance? inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { vector } declare hashtable instance? ] \ instance? inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { assoc } declare hashtable instance? ] \ instance? inlined?
|
||||
] unit-test
|
||||
|
||||
TUPLE: declared-fixnum { x fixnum } ;
|
||||
|
||||
[ t ] [
|
||||
[ { declared-fixnum } declare [ 1 + ] change-x ]
|
||||
{ + fixnum+ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { declared-fixnum } declare x>> drop ]
|
||||
{ slot } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ array } declare length
|
||||
1 + dup 100 fixnum> [ 1 fixnum+ ] when
|
||||
] \ fixnum+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ [ resize-array ] keep length ] \ length inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ dup 0 > [ sqrt ] when ] \ sqrt inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { utf8 } declare decode-char ] \ decode-char inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { ascii } declare decode-char ] \ decode-char inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare [ 256 mod ] map
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare [ 0 >= ] map
|
||||
] { >= fixnum>= } inlined?
|
||||
] unit-test
|
|
@ -1,5 +1,106 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences sequences.deep combinators fry
|
||||
namespaces
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.branches ;
|
||||
IN: compiler.tree.cleanup
|
||||
|
||||
: cleanup ( nodes -- nodes' ) ;
|
||||
! A phase run after propagation to finish the job, so to speak.
|
||||
! Codifies speculative inlining decisions, deletes branches
|
||||
! marked as never taken, and flattens local recursive blocks
|
||||
! that do not call themselves.
|
||||
|
||||
GENERIC: cleanup* ( node -- node/nodes )
|
||||
|
||||
: cleanup ( nodes -- nodes' )
|
||||
#! We don't recurse into children here, instead the methods
|
||||
#! do it since the logic is a bit more involved
|
||||
[ cleanup* ] map flatten ;
|
||||
|
||||
: cleanup-constant-folding ( #call -- nodes )
|
||||
[
|
||||
[ node-output-infos ] [ out-d>> ] bi
|
||||
[ [ literal>> ] dip #push ] 2map
|
||||
]
|
||||
[ in-d>> #drop ] bi prefix ;
|
||||
|
||||
: cleanup-inlining ( #call -- nodes )
|
||||
body>> cleanup ;
|
||||
|
||||
M: #call cleanup*
|
||||
{
|
||||
{ [ dup node-output-infos [ literal?>> ] all? ] [ cleanup-constant-folding ] }
|
||||
{ [ dup body>> ] [ cleanup-inlining ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
GENERIC: delete-node ( node -- )
|
||||
|
||||
M: #call-recursive delete-node
|
||||
dup label>> [ [ eq? not ] with filter ] change-calls drop ;
|
||||
|
||||
M: #return-recursive delete-node
|
||||
label>> f >>return drop ;
|
||||
|
||||
M: node delete-node drop ;
|
||||
|
||||
: delete-nodes ( nodes -- ) [ delete-node ] each-node ;
|
||||
|
||||
: delete-unreachable-branches ( #branch -- )
|
||||
dup live-branches>> '[
|
||||
,
|
||||
[ [ [ drop ] [ delete-nodes ] if ] 2each ]
|
||||
[ select-children ]
|
||||
2bi
|
||||
] change-children drop ;
|
||||
|
||||
: fold-only-branch ( #branch -- node/nodes )
|
||||
#! If only one branch is live we don't need to branch at
|
||||
#! all; just drop the condition value.
|
||||
dup live-children sift dup length 1 =
|
||||
[ first swap in-d>> #drop prefix ] [ drop ] if ;
|
||||
|
||||
SYMBOL: live-branches
|
||||
|
||||
: cleanup-children ( #branch -- )
|
||||
[ [ cleanup ] map ] change-children drop ;
|
||||
|
||||
M: #branch cleanup*
|
||||
{
|
||||
[ live-branches>> live-branches set ]
|
||||
[ delete-unreachable-branches ]
|
||||
[ cleanup-children ]
|
||||
[ fold-only-branch ]
|
||||
} cleave ;
|
||||
|
||||
: cleanup-phi-in ( phi-in live-branches -- phi-in' )
|
||||
swap dup empty?
|
||||
[ nip ] [ flip swap select-children sift flip ] if ;
|
||||
|
||||
M: #phi cleanup*
|
||||
#! Remove #phi function inputs which no longer exist.
|
||||
live-branches get {
|
||||
[ '[ , cleanup-phi-in ] change-phi-in-d ]
|
||||
[ '[ , cleanup-phi-in ] change-phi-in-r ]
|
||||
[ '[ , cleanup-phi-in ] change-phi-info-d ]
|
||||
[ '[ , cleanup-phi-in ] change-phi-info-r ]
|
||||
} cleave ;
|
||||
|
||||
: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;
|
||||
|
||||
: flatten-recursive ( #recursive -- nodes )
|
||||
#! convert #enter-recursive and #return-recursive into
|
||||
#! #copy nodes.
|
||||
child>>
|
||||
unclip >copy prefix
|
||||
unclip-last >copy suffix ;
|
||||
|
||||
M: #recursive cleanup*
|
||||
#! Inline bodies of #recursive blocks with no calls left.
|
||||
[ cleanup ] change-child
|
||||
dup label>> calls>> empty? [ flatten-recursive ] when ;
|
||||
|
||||
M: node cleanup* ;
|
||||
|
|
|
@ -3,3 +3,4 @@ USING: compiler.tree.combinators tools.test kernel ;
|
|||
|
||||
{ 1 0 } [ [ drop ] each-node ] must-infer-as
|
||||
{ 1 1 } [ [ ] map-nodes ] must-infer-as
|
||||
{ 1 1 } [ [ ] contains-node? ] must-infer-as
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: fry kernel accessors sequences sequences.deep
|
|||
compiler.tree ;
|
||||
IN: compiler.tree.combinators
|
||||
|
||||
: each-node ( nodes quot -- )
|
||||
: each-node ( nodes quot: ( node -- ) -- )
|
||||
dup dup '[
|
||||
, [
|
||||
dup #branch? [
|
||||
|
@ -15,7 +15,7 @@ IN: compiler.tree.combinators
|
|||
] [ drop ] if
|
||||
] if
|
||||
] bi
|
||||
] each ; inline
|
||||
] each ; inline recursive
|
||||
|
||||
: map-nodes ( nodes quot: ( node -- node' ) -- nodes )
|
||||
dup dup '[
|
||||
|
@ -28,3 +28,19 @@ IN: compiler.tree.combinators
|
|||
] when
|
||||
] if
|
||||
] map flatten ; inline recursive
|
||||
|
||||
: contains-node? ( nodes quot: ( node -- ? ) -- ? )
|
||||
dup dup '[
|
||||
, keep swap [ drop t ] [
|
||||
dup #branch? [
|
||||
children>> [ , contains-node? ] contains?
|
||||
] [
|
||||
dup #recursive? [
|
||||
child>> , contains-node?
|
||||
] [ drop f ] if
|
||||
] if
|
||||
] if
|
||||
] contains? ; inline recursive
|
||||
|
||||
: select-children ( seq flags -- seq' )
|
||||
[ [ drop f ] unless ] 2map ;
|
||||
|
|
|
@ -5,6 +5,9 @@ kernel accessors fry
|
|||
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
|
||||
IN: compiler.tree.copy-equiv
|
||||
|
||||
! Two values are copy-equivalent if they are always identical
|
||||
! at run-time ("DS" relation).
|
||||
|
||||
! Disjoint set of copy equivalence
|
||||
SYMBOL: copies
|
||||
|
||||
|
@ -49,10 +52,13 @@ M: #phi compute-copy-equiv*
|
|||
|
||||
M: node compute-copy-equiv* drop ;
|
||||
|
||||
: compute-copy-equiv ( node -- node )
|
||||
<disjoint-set> copies set
|
||||
dup [
|
||||
: amend-copy-equiv ( node -- )
|
||||
[
|
||||
[ node-defs-values [ introduce-value ] each ]
|
||||
[ compute-copy-equiv* ]
|
||||
bi
|
||||
] each-node ;
|
||||
|
||||
: compute-copy-equiv ( node -- node )
|
||||
<disjoint-set> copies set
|
||||
dup amend-copy-equiv ;
|
||||
|
|
|
@ -0,0 +1,5 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: compiler.tree.loop-detection
|
||||
|
||||
: detect-loops ( nodes -- nodes' ) ;
|
|
@ -51,13 +51,16 @@ M: node count-introductions* drop ;
|
|||
! Collect label info
|
||||
GENERIC: collect-label-info ( node -- )
|
||||
|
||||
M: #return-recursive collect-label-info dup label>> (>>return) ;
|
||||
M: #return-recursive collect-label-info
|
||||
dup label>> (>>return) ;
|
||||
|
||||
M: #call-recursive collect-label-info dup label>> calls>> push ;
|
||||
M: #call-recursive collect-label-info
|
||||
dup label>> calls>> push ;
|
||||
|
||||
M: #recursive collect-label-info
|
||||
[ label>> ] [ child>> count-introductions ] bi
|
||||
>>introductions drop ;
|
||||
[ label>> V{ } clone >>calls ]
|
||||
[ child>> count-introductions ]
|
||||
bi >>introductions drop ;
|
||||
|
||||
M: node collect-label-info drop ;
|
||||
|
||||
|
|
|
@ -4,6 +4,7 @@ USING: fry kernel sequences assocs accessors namespaces
|
|||
math.intervals arrays classes.algebra combinators
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.simple
|
||||
|
@ -19,17 +20,22 @@ M: #if child-constraints
|
|||
M: #dispatch child-constraints
|
||||
children>> length f <repetition> ;
|
||||
|
||||
GENERIC: live-children ( #branch -- children )
|
||||
GENERIC: live-branches ( #branch -- indices )
|
||||
|
||||
M: #if live-children
|
||||
[ children>> ] [ in-d>> first value-info possible-boolean-values ] bi
|
||||
[ t swap memq? [ first ] [ drop f ] if ]
|
||||
[ f swap memq? [ second ] [ drop f ] if ]
|
||||
2bi 2array ;
|
||||
M: #if live-branches
|
||||
in-d>> first value-info class>> {
|
||||
{ [ dup null class<= ] [ { f f } ] }
|
||||
{ [ dup true-class? ] [ { t f } ] }
|
||||
{ [ dup false-class? ] [ { f t } ] }
|
||||
[ { t t } ]
|
||||
} cond nip ;
|
||||
|
||||
M: #dispatch live-children
|
||||
[ children>> ] [ in-d>> first value-info interval>> ] bi
|
||||
'[ , interval-contains? [ drop f ] unless ] map-index ;
|
||||
M: #dispatch live-branches
|
||||
[ children>> length ] [ in-d>> first value-info interval>> ] bi
|
||||
'[ , interval-contains? ] map ;
|
||||
|
||||
: live-children ( #branch -- children )
|
||||
[ children>> ] [ live-branches>> ] bi select-children ;
|
||||
|
||||
SYMBOL: infer-children-data
|
||||
|
||||
|
@ -56,22 +62,27 @@ SYMBOL: infer-children-data
|
|||
infer-children-data get
|
||||
'[ , [ [ value-info ] bind ] 2map ] map ;
|
||||
|
||||
: annotate-phi-node ( #phi -- )
|
||||
: annotate-phi-inputs ( #phi -- )
|
||||
dup phi-in-d>> compute-phi-input-infos >>phi-info-d
|
||||
dup phi-in-r>> compute-phi-input-infos >>phi-info-r
|
||||
dup [ out-d>> ] [ out-r>> ] bi append extract-value-info >>info
|
||||
drop ;
|
||||
|
||||
: annotate-phi-outputs ( #phi -- )
|
||||
dup [ out-d>> ] [ out-r>> ] bi append extract-value-info
|
||||
>>info drop ;
|
||||
|
||||
: merge-value-infos ( infos outputs -- )
|
||||
[ [ value-infos-union ] map ] dip set-value-infos ;
|
||||
|
||||
SYMBOL: condition-value
|
||||
|
||||
M: #phi propagate-before ( #phi -- )
|
||||
[ annotate-phi-node ]
|
||||
[ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ]
|
||||
[ [ phi-info-r>> ] [ out-r>> ] bi merge-value-infos ]
|
||||
tri ;
|
||||
{
|
||||
[ annotate-phi-inputs ]
|
||||
[ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ]
|
||||
[ [ phi-info-r>> ] [ out-r>> ] bi merge-value-infos ]
|
||||
[ annotate-phi-outputs ]
|
||||
} cleave ;
|
||||
|
||||
: branch-phi-constraints ( output values booleans -- )
|
||||
{
|
||||
|
@ -115,6 +126,7 @@ M: #phi propagate-around ( #phi -- )
|
|||
[ propagate-before ] [ propagate-after ] bi ;
|
||||
|
||||
M: #branch propagate-around
|
||||
dup live-branches >>live-branches
|
||||
[ infer-children ] [ annotate-node ] bi ;
|
||||
|
||||
M: #if propagate-around
|
||||
|
|
|
@ -107,6 +107,3 @@ M: sequence assume* [ assume ] each ;
|
|||
: t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
|
||||
|
||||
: f--> ( constraint boolean-value -- constraint' ) =f swap --> ;
|
||||
|
||||
: save-constraints ( quot -- )
|
||||
constraints get clone slip constraints set ; inline
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: accessors math math.intervals sequences classes.algebra
|
||||
math kernel tools.test compiler.tree.propagation.info ;
|
||||
math kernel tools.test compiler.tree.propagation.info arrays ;
|
||||
IN: compiler.tree.propagation.info.tests
|
||||
|
||||
[ f ] [ 0.0 -0.0 eql? ] unit-test
|
||||
|
@ -63,3 +63,11 @@ IN: compiler.tree.propagation.info.tests
|
|||
] unit-test
|
||||
|
||||
[ ] [ { } value-infos-union drop ] unit-test
|
||||
|
||||
TUPLE: test-tuple { x read-only } ;
|
||||
|
||||
[ t ] [
|
||||
f f 3 <literal-info> 3array test-tuple <tuple-info> dup
|
||||
object <class-info>
|
||||
value-info-intersect =
|
||||
] unit-test
|
||||
|
|
|
@ -132,9 +132,14 @@ DEFER: (value-info-intersect)
|
|||
} cond ;
|
||||
|
||||
: intersect-slots ( info1 info2 -- slots )
|
||||
[ slots>> ] bi@
|
||||
2dup [ length ] bi@ =
|
||||
[ [ intersect-slot ] 2map ] [ 2drop f ] if ;
|
||||
[ slots>> ] bi@ {
|
||||
{ [ dup not ] [ drop ] }
|
||||
{ [ over not ] [ nip ] }
|
||||
[
|
||||
2dup [ length ] bi@ =
|
||||
[ [ intersect-slot ] 2map ] [ 2drop f ] if
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: (value-info-intersect) ( info1 info2 -- info )
|
||||
[ <value-info> ] 2dip
|
||||
|
|
|
@ -1,3 +1,144 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays sequences math math.order
|
||||
math.partial-dispatch generic generic.standard classes.algebra
|
||||
classes.union sets quotations assocs combinators words
|
||||
namespaces
|
||||
compiler.tree
|
||||
compiler.tree.builder
|
||||
compiler.tree.copy-equiv
|
||||
compiler.tree.normalization
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes ;
|
||||
IN: compiler.tree.propagation.inlining
|
||||
|
||||
! Splicing nodes
|
||||
GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
|
||||
|
||||
M: word splicing-nodes
|
||||
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
|
||||
|
||||
M: quotation splicing-nodes
|
||||
[ [ out-d>> ] [ in-d>> ] bi ] dip
|
||||
build-tree-with
|
||||
rot #copy suffix
|
||||
normalize ;
|
||||
|
||||
: propagate-body ( #call -- )
|
||||
body>> [ amend-copy-equiv ] [ (propagate) ] bi ;
|
||||
|
||||
! Dispatch elimination
|
||||
: eliminate-dispatch ( #call word/quot/f -- ? )
|
||||
[
|
||||
over method>> over = [ drop ] [
|
||||
2dup splicing-nodes
|
||||
[ >>method ] [ >>body ] bi*
|
||||
] if
|
||||
propagate-body t
|
||||
] [ f >>method f >>body drop f ] if* ;
|
||||
|
||||
: inlining-standard-method ( #call word -- method/f )
|
||||
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
|
||||
[ swap nth value-info class>> ] dip
|
||||
specific-method ;
|
||||
|
||||
: inline-standard-method ( #call word -- ? )
|
||||
dupd inlining-standard-method eliminate-dispatch ;
|
||||
|
||||
: normalize-math-class ( class -- class' )
|
||||
{
|
||||
null
|
||||
fixnum bignum integer
|
||||
ratio rational
|
||||
float real
|
||||
complex number
|
||||
object
|
||||
} [ class<= ] with find nip ;
|
||||
|
||||
: inlining-math-method ( #call word -- quot/f )
|
||||
swap in-d>>
|
||||
first2 [ value-info class>> normalize-math-class ] bi@
|
||||
3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
|
||||
|
||||
: inline-math-method ( #call word -- ? )
|
||||
dupd inlining-math-method eliminate-dispatch ;
|
||||
|
||||
: inlining-math-partial ( #call word -- quot/f )
|
||||
[ "derived-from" word-prop first inlining-math-method ]
|
||||
[ nip 1quotation ] 2bi
|
||||
[ = not ] [ drop ] 2bi and ;
|
||||
|
||||
: inline-math-partial ( #call word -- ? )
|
||||
dupd inlining-math-partial eliminate-dispatch ;
|
||||
|
||||
! Method body inlining
|
||||
SYMBOL: recursive-calls
|
||||
DEFER: (flat-length)
|
||||
|
||||
: word-flat-length ( word -- n )
|
||||
{
|
||||
! not inline
|
||||
{ [ dup inline? not ] [ drop 1 ] }
|
||||
! recursive and inline
|
||||
{ [ dup recursive-calls get key? ] [ drop 10 ] }
|
||||
! inline
|
||||
[ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
|
||||
} cond ;
|
||||
|
||||
: (flat-length) ( seq -- n )
|
||||
[
|
||||
{
|
||||
{ [ dup quotation? ] [ (flat-length) 2 + ] }
|
||||
{ [ dup array? ] [ (flat-length) ] }
|
||||
{ [ dup word? ] [ word-flat-length ] }
|
||||
[ drop 0 ]
|
||||
} cond
|
||||
] sigma ;
|
||||
|
||||
: flat-length ( word -- n )
|
||||
H{ } clone recursive-calls [
|
||||
[ recursive-calls get conjoin ]
|
||||
[ def>> (flat-length) 5 /i ]
|
||||
bi
|
||||
] with-variable ;
|
||||
|
||||
: classes-known? ( #call -- ? )
|
||||
in-d>> [
|
||||
value-info class>>
|
||||
[ class-types length 1 = ]
|
||||
[ union-class? not ]
|
||||
bi and
|
||||
] contains? ;
|
||||
|
||||
: inlining-rank ( #call word -- n )
|
||||
[ classes-known? 2 0 ? ]
|
||||
[
|
||||
{
|
||||
[ flat-length 24 swap [-] 4 /i ]
|
||||
[ "default" word-prop -4 0 ? ]
|
||||
[ "specializer" word-prop 1 0 ? ]
|
||||
[ method-body? 1 0 ? ]
|
||||
} cleave
|
||||
] bi* + + + + ;
|
||||
|
||||
: should-inline? ( #call word -- ? )
|
||||
inlining-rank 5 >= ;
|
||||
|
||||
SYMBOL: history
|
||||
|
||||
: remember-inlining ( word -- )
|
||||
history get [ swap suffix ] change ;
|
||||
|
||||
: inline-word ( #call word -- )
|
||||
dup history get memq? [
|
||||
2drop
|
||||
] [
|
||||
[
|
||||
dup remember-inlining
|
||||
dupd def>> splicing-nodes >>body
|
||||
propagate-body
|
||||
] with-scope
|
||||
] if ;
|
||||
|
||||
: inline-method-body ( #call word -- ? )
|
||||
2dup should-inline? [ inline-word t ] [ 2drop f ] if ;
|
||||
|
|
|
@ -173,8 +173,8 @@ generic-comparison-ops [
|
|||
} case ;
|
||||
|
||||
comparison-ops [
|
||||
[
|
||||
dup '[ , fold-comparison ] +outputs+ set-word-prop
|
||||
dup '[
|
||||
[ , fold-comparison ] +outputs+ set-word-prop
|
||||
] each-derived-op
|
||||
] each
|
||||
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences accessors kernel
|
||||
USING: sequences accessors kernel assocs sequences
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.nodes
|
||||
|
@ -14,4 +15,20 @@ GENERIC: propagate-after ( node -- )
|
|||
|
||||
GENERIC: propagate-around ( node -- )
|
||||
|
||||
: (propagate) ( node -- ) [ [ propagate-around ] each ] when* ;
|
||||
: (propagate) ( node -- ) [ propagate-around ] each ;
|
||||
|
||||
: extract-value-info ( values -- assoc )
|
||||
[ dup value-info ] H{ } map>assoc ;
|
||||
|
||||
: annotate-node ( node -- )
|
||||
dup
|
||||
[ node-defs-values ] [ node-uses-values ] bi append
|
||||
extract-value-info
|
||||
>>info drop ;
|
||||
|
||||
M: node propagate-before drop ;
|
||||
|
||||
M: node propagate-after drop ;
|
||||
|
||||
M: node propagate-around
|
||||
[ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;
|
||||
|
|
|
@ -5,11 +5,10 @@ accessors sequences arrays kernel.private vectors
|
|||
alien.accessors alien.c-types sequences.private
|
||||
byte-arrays classes.algebra classes.tuple.private
|
||||
math.functions math.private strings layouts
|
||||
compiler.tree.propagation.info ;
|
||||
compiler.tree.propagation.info slots.private ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
\ propagate must-infer
|
||||
\ propagate/node must-infer
|
||||
|
||||
: final-info ( quot -- seq )
|
||||
build-tree
|
||||
|
@ -52,6 +51,10 @@ IN: compiler.tree.propagation.tests
|
|||
|
||||
[ V{ integer } ] [ [ /i ] final-classes ] unit-test
|
||||
|
||||
[ V{ integer } ] [
|
||||
[ { integer } declare bitnot ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
|
||||
|
||||
[ V{ integer } ] [
|
||||
|
@ -316,7 +319,7 @@ cell-bits 32 = [
|
|||
! Array length propagation
|
||||
[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
|
||||
|
||||
[ V{ t } ] [ [ [ 10 f <array> ] [ 10 <byte-array> ] if length 10 = ] final-literals ] unit-test
|
||||
[ V{ t } ] [ [ [ 10 f <array> length ] [ 10 <byte-array> length ] if 10 = ] final-literals ] unit-test
|
||||
|
||||
[ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test
|
||||
|
||||
|
@ -325,15 +328,6 @@ TUPLE: prop-test-tuple { x integer } ;
|
|||
|
||||
[ V{ integer } ] [ [ { prop-test-tuple } declare x>> ] final-classes ] unit-test
|
||||
|
||||
TUPLE: another-prop-test-tuple { x ratio initial: 1/2 } ;
|
||||
|
||||
UNION: prop-test-union prop-test-tuple another-prop-test-tuple ;
|
||||
|
||||
[ t ] [
|
||||
[ { prop-test-union } declare x>> ] final-classes first
|
||||
rational class=
|
||||
] unit-test
|
||||
|
||||
TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
|
||||
|
||||
[ V{ T{ fold-boa-test-tuple f 1 2 3 } } ]
|
||||
|
@ -377,6 +371,8 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
|
|||
] final-classes
|
||||
] unit-test
|
||||
|
||||
[ ] [ [ dup 3 slot swap 4 slot dup 3 slot swap 4 slot ] final-info drop ] unit-test
|
||||
|
||||
[ V{ number } ] [ [ [ "Oops" throw ] [ 2 + ] if ] final-classes ] unit-test
|
||||
[ V{ number } ] [ [ [ 2 + ] [ "Oops" throw ] if ] final-classes ] unit-test
|
||||
|
||||
|
@ -404,8 +400,13 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
|
|||
|
||||
[ V{ integer array } ] [
|
||||
[
|
||||
3 { 2 1 } mixed-mutable-immutable boa
|
||||
[ x>> ] [ y>> ] bi
|
||||
3 { 2 1 } mixed-mutable-immutable boa [ x>> ] [ y>> ] bi
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ array integer } ] [
|
||||
[
|
||||
3 { 2 1 } mixed-mutable-immutable boa [ y>> ] [ x>> ] bi
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
|
@ -459,3 +460,18 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
|
|||
[ V{ fixnum } ] [ [ 1 10 [ dup 10 < [ 2 * ] when ] times ] final-classes ] unit-test
|
||||
|
||||
[ V{ integer } ] [ [ 0 2 100 ^ [ nip ] each-integer ] final-classes ] unit-test
|
||||
|
||||
[ ] [ [ [ ] [ ] compose curry call ] final-info drop ] unit-test
|
||||
|
||||
[ V{ } ] [
|
||||
[ [ drop ] [ drop ] compose curry (each-integer) ] final-classes
|
||||
] unit-test
|
||||
|
||||
GENERIC: iterate ( obj -- next-obj ? )
|
||||
M: fixnum iterate f ;
|
||||
M: array iterate first t ;
|
||||
|
||||
: dead-loop ( obj -- final-obj )
|
||||
iterate [ dead-loop ] when ; inline recursive
|
||||
|
||||
[ V{ fixnum } ] [ [ { fixnum } declare dead-loop ] final-classes ] unit-test
|
||||
|
|
|
@ -12,15 +12,9 @@ compiler.tree.propagation.constraints
|
|||
compiler.tree.propagation.known-words ;
|
||||
IN: compiler.tree.propagation
|
||||
|
||||
: propagate-with ( node infos -- )
|
||||
: propagate ( node -- node )
|
||||
[
|
||||
H{ } clone constraints set
|
||||
>hashtable value-infos set
|
||||
(propagate)
|
||||
H{ } clone value-infos set
|
||||
dup (propagate)
|
||||
] with-scope ;
|
||||
|
||||
: propagate ( node -- node )
|
||||
dup f propagate-with ;
|
||||
|
||||
: propagate/node ( node existing -- )
|
||||
info>> propagate-with ;
|
||||
|
|
|
@ -4,6 +4,7 @@ USING: kernel sequences accessors arrays fry math.intervals
|
|||
combinators
|
||||
stack-checker.inlining
|
||||
compiler.tree
|
||||
compiler.tree.copy-equiv
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.simple
|
||||
|
@ -53,11 +54,14 @@ M: #recursive propagate-around ( #recursive -- )
|
|||
iter-counter get 10 > [ "Oops" throw ] when
|
||||
dup label>> t >>fixed-point drop [
|
||||
[
|
||||
copies [ clone ] change
|
||||
constraints [ clone ] change
|
||||
|
||||
child>>
|
||||
[ first propagate-recursive-phi ]
|
||||
[ (propagate) ]
|
||||
bi
|
||||
] save-constraints
|
||||
] with-scope
|
||||
] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ;
|
||||
|
||||
: generalize-return-interval ( info -- info' )
|
||||
|
|
|
@ -1,17 +1,21 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors kernel sequences sequences.private assocs
|
||||
words namespaces classes.algebra combinators classes
|
||||
classes.tuple classes.tuple.private continuations arrays
|
||||
byte-arrays strings math math.private slots
|
||||
USING: fry accessors kernel sequences sequences.private assocs words
|
||||
namespaces classes.algebra combinators classes classes.tuple
|
||||
classes.tuple.private continuations arrays byte-arrays strings
|
||||
math math.partial-dispatch math.private slots generic
|
||||
generic.standard generic.math
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.slots
|
||||
compiler.tree.propagation.inlining
|
||||
compiler.tree.propagation.constraints ;
|
||||
IN: compiler.tree.propagation.simple
|
||||
|
||||
! Propagation for straight-line code.
|
||||
|
||||
M: #introduce propagate-before
|
||||
value>> object <class-info> swap set-value-info ;
|
||||
|
||||
|
@ -40,91 +44,61 @@ M: #declare propagate-before
|
|||
[ [ in-d>> ] [ out-d>> ] bi append ] dip
|
||||
with-datastack first assume ;
|
||||
|
||||
: compute-constraints ( #call -- )
|
||||
dup word>> +constraints+ word-prop [ custom-constraints ] [
|
||||
dup word>> predicate? [
|
||||
[ in-d>> first ]
|
||||
[ word>> "predicating" word-prop ]
|
||||
[ out-d>> first ]
|
||||
tri predicate-constraints assume
|
||||
] [ drop ] if
|
||||
: compute-constraints ( #call word -- )
|
||||
dup +constraints+ word-prop [ nip custom-constraints ] [
|
||||
dup predicate? [
|
||||
[ [ in-d>> first ] [ out-d>> first ] bi ]
|
||||
[ "predicating" word-prop ] bi*
|
||||
swap predicate-constraints assume
|
||||
] [ 2drop ] if
|
||||
] if* ;
|
||||
|
||||
: call-outputs-quot ( node -- infos )
|
||||
[ in-d>> [ value-info ] map ]
|
||||
[ word>> +outputs+ word-prop ]
|
||||
bi with-datastack ;
|
||||
: call-outputs-quot ( #call word -- infos )
|
||||
[ in-d>> [ value-info ] map ] [ +outputs+ word-prop ] bi*
|
||||
with-datastack ;
|
||||
|
||||
: foldable-word? ( #call -- ? )
|
||||
dup word>> "foldable" word-prop [
|
||||
drop t
|
||||
] [
|
||||
dup word>> \ <tuple-boa> eq? [
|
||||
in-d>> peek value-info literal>> immutable-tuple-class?
|
||||
] [
|
||||
drop f
|
||||
] if
|
||||
] if ;
|
||||
: foldable-call? ( #call word -- ? )
|
||||
"foldable" word-prop
|
||||
[ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
|
||||
|
||||
: foldable-call? ( #call -- ? )
|
||||
dup word>> "foldable" word-prop [
|
||||
in-d>> [ value-info literal?>> ] all?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: fold-call ( #call -- infos )
|
||||
: fold-call ( #call word -- infos )
|
||||
[ in-d>> [ value-info literal>> ] map ]
|
||||
[ word>> [ execute ] curry ]
|
||||
bi with-datastack
|
||||
[ [ execute ] curry ]
|
||||
bi* with-datastack
|
||||
[ <literal-info> ] map ;
|
||||
|
||||
: default-output-value-infos ( node -- infos )
|
||||
dup word>> "default-output-classes" word-prop [
|
||||
class-infos
|
||||
] [
|
||||
out-d>> length object <class-info> <repetition>
|
||||
] ?if ;
|
||||
: default-output-value-infos ( #call word -- infos )
|
||||
"default-output-classes" word-prop
|
||||
[ class-infos ] [ out-d>> length object <class-info> <repetition> ] ?if ;
|
||||
|
||||
: output-value-infos ( node -- infos )
|
||||
: output-value-infos ( #call word -- infos )
|
||||
{
|
||||
{ [ dup foldable-call? ] [ fold-call ] }
|
||||
{ [ 2dup foldable-call? ] [ fold-call ] }
|
||||
{ [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
|
||||
{ [ dup word>> reader? ] [ reader-word-outputs ] }
|
||||
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
|
||||
{ [ dup length-accessor? ] [ propagate-length ] }
|
||||
{ [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
|
||||
{ [ dup +outputs+ word-prop ] [ call-outputs-quot ] }
|
||||
[ default-output-value-infos ]
|
||||
} cond ;
|
||||
|
||||
M: #call propagate-before
|
||||
[ [ output-value-infos ] [ out-d>> ] bi set-value-infos ]
|
||||
[ compute-constraints ]
|
||||
bi ;
|
||||
|
||||
M: node propagate-before drop ;
|
||||
|
||||
: propagate-input-classes ( node -- )
|
||||
[ word>> "input-classes" word-prop class-infos ] [ in-d>> ] bi
|
||||
refine-value-infos ;
|
||||
|
||||
M: #call propagate-after
|
||||
: do-inlining ( #call word -- ? )
|
||||
{
|
||||
{ [ dup reader? ] [ reader-word-inputs ] }
|
||||
{ [ dup word>> "input-classes" word-prop ] [ propagate-input-classes ] }
|
||||
[ drop ]
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ dup math-partial? ] [ inline-math-partial ] }
|
||||
{ [ dup method-body? ] [ inline-method-body ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
M: node propagate-after drop ;
|
||||
M: #call propagate-before
|
||||
dup word>> 2dup do-inlining [ 2drop ] [
|
||||
[ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
|
||||
[ compute-constraints ]
|
||||
2bi
|
||||
] if ;
|
||||
|
||||
: extract-value-info ( values -- assoc )
|
||||
[ dup value-info ] H{ } map>assoc ;
|
||||
: propagate-input-classes ( node input-classes -- )
|
||||
class-infos swap in-d>> refine-value-infos ;
|
||||
|
||||
: annotate-node ( node -- )
|
||||
dup
|
||||
[ node-defs-values ] [ node-uses-values ] bi append
|
||||
extract-value-info
|
||||
>>info drop ;
|
||||
|
||||
M: node propagate-around
|
||||
[ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;
|
||||
M: #call propagate-after
|
||||
dup word>> "input-classes" word-prop dup
|
||||
[ propagate-input-classes ] [ 2drop ] if ;
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: fry assocs arrays byte-arrays strings accessors sequences
|
||||
kernel slots classes.algebra classes.tuple classes.tuple.private
|
||||
words math math.private combinators sequences.private namespaces
|
||||
compiler.tree.propagation.info ;
|
||||
classes compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.slots
|
||||
|
||||
! Propagation of immutable slots and array lengths
|
||||
|
@ -13,8 +13,8 @@ IN: compiler.tree.propagation.slots
|
|||
|
||||
UNION: fixed-length-sequence array byte-array string ;
|
||||
|
||||
: sequence-constructor? ( node -- ? )
|
||||
word>> { <array> <byte-array> <string> } memq? ;
|
||||
: sequence-constructor? ( word -- ? )
|
||||
{ <array> <byte-array> <string> } memq? ;
|
||||
|
||||
: constructor-output-class ( word -- class )
|
||||
{
|
||||
|
@ -23,21 +23,13 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
{ <string> string }
|
||||
} at ;
|
||||
|
||||
: propagate-sequence-constructor ( node -- infos )
|
||||
[ word>> constructor-output-class <class-info> ]
|
||||
: propagate-sequence-constructor ( #call word -- infos )
|
||||
[ in-d>> first <sequence-info> ]
|
||||
bi value-info-intersect 1array ;
|
||||
[ constructor-output-class <class-info> ]
|
||||
bi* value-info-intersect 1array ;
|
||||
|
||||
: length-accessor? ( node -- ? )
|
||||
dup in-d>> first value-info class>> fixed-length-sequence class<=
|
||||
[ word>> \ length eq? ] [ drop f ] if ;
|
||||
|
||||
: propagate-length ( node -- infos )
|
||||
in-d>> first value-info length>>
|
||||
[ array-capacity <class-info> ] unless* 1array ;
|
||||
|
||||
: tuple-constructor? ( node -- ? )
|
||||
word>> { <tuple-boa> <complex> } memq? ;
|
||||
: tuple-constructor? ( word -- ? )
|
||||
{ <tuple-boa> <complex> } memq? ;
|
||||
|
||||
: read-only-slots ( values class -- slots )
|
||||
#! Delegation.
|
||||
|
@ -49,7 +41,7 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
[ , f , [ literal>> ] map % ] { } make >tuple
|
||||
<literal-info> ;
|
||||
|
||||
: propagate-<tuple-boa> ( node -- info )
|
||||
: propagate-<tuple-boa> ( #call -- info )
|
||||
#! Delegation
|
||||
in-d>> [ value-info ] map unclip-last
|
||||
literal>> class>> [ read-only-slots ] keep
|
||||
|
@ -59,72 +51,45 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
<tuple-info>
|
||||
] if ;
|
||||
|
||||
: propagate-<complex> ( node -- info )
|
||||
: propagate-<complex> ( #call -- info )
|
||||
in-d>> [ value-info ] map complex <tuple-info> ;
|
||||
|
||||
: propagate-tuple-constructor ( node -- infos )
|
||||
dup word>> {
|
||||
: propagate-tuple-constructor ( #call word -- infos )
|
||||
{
|
||||
{ \ <tuple-boa> [ propagate-<tuple-boa> ] }
|
||||
{ \ <complex> [ propagate-<complex> ] }
|
||||
} case 1array ;
|
||||
|
||||
: relevant-methods ( node -- methods )
|
||||
[ word>> "methods" word-prop ]
|
||||
[ in-d>> first value-info class>> ] bi
|
||||
'[ drop , classes-intersect? ] assoc-filter ;
|
||||
|
||||
: relevant-slots ( node -- slots )
|
||||
relevant-methods [ nip "reading" word-prop ] { } assoc>map ;
|
||||
|
||||
: no-reader-methods ( input slots -- info )
|
||||
2drop null-info ;
|
||||
|
||||
: same-offset ( slots -- slot/f )
|
||||
dup [ dup [ read-only>> ] when ] all? [
|
||||
[ offset>> ] map dup all-equal? [ first ] [ drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
: (reader-word-outputs) ( reader -- info )
|
||||
null
|
||||
[ [ class>> ] [ object ] if* class-or ] reduce
|
||||
<class-info> ;
|
||||
|
||||
: tuple>array* ( tuple -- array )
|
||||
prepare-tuple>array
|
||||
>r copy-tuple-slots r>
|
||||
prefix ;
|
||||
|
||||
: literal-info-slot ( slot info -- info' )
|
||||
{
|
||||
{ [ dup tuple? ] [
|
||||
tuple>array* nth <literal-info>
|
||||
] }
|
||||
{ [ dup complex? ] [
|
||||
[ real-part ] [ imaginary-part ] bi
|
||||
2array nth <literal-info>
|
||||
] }
|
||||
} cond ;
|
||||
: read-only-slot? ( n class -- ? )
|
||||
all-slots [ offset>> = ] with find nip
|
||||
dup [ read-only>> ] when ;
|
||||
|
||||
: literal-info-slot ( slot object -- info/f )
|
||||
2dup class read-only-slot? [
|
||||
{
|
||||
{ [ dup tuple? ] [
|
||||
[ 1- ] [ tuple>array* ] bi* nth <literal-info>
|
||||
] }
|
||||
{ [ dup complex? ] [
|
||||
[ 1- ] [ [ real-part ] [ imaginary-part ] bi ] bi*
|
||||
2array nth <literal-info>
|
||||
] }
|
||||
} cond
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
: length-accessor? ( slot info -- ? )
|
||||
[ 1 = ] [ length>> ] bi* and ;
|
||||
|
||||
: value-info-slot ( slot info -- info' )
|
||||
#! Delegation.
|
||||
{
|
||||
{ [ over 0 = ] [ 2drop fixnum <class-info> ] }
|
||||
{ [ dup literal?>> ] [ [ 1- ] [ literal>> ] bi* literal-info-slot ] }
|
||||
{ [ 2dup length-accessor? ] [ nip length>> ] }
|
||||
{ [ dup literal?>> ] [ literal>> literal-info-slot ] }
|
||||
[ [ 1- ] [ slots>> ] bi* ?nth ]
|
||||
} cond ;
|
||||
|
||||
: reader-word-outputs ( node -- infos )
|
||||
[ relevant-slots ] [ in-d>> first ] bi
|
||||
over empty? [ no-reader-methods ] [
|
||||
over same-offset dup
|
||||
[ swap value-info value-info-slot ] [ 2drop f ] if
|
||||
[ ] [ (reader-word-outputs) ] ?if
|
||||
] if 1array ;
|
||||
|
||||
: reader-word-inputs ( node -- )
|
||||
[ in-d>> first ] [
|
||||
relevant-slots keys
|
||||
object [ class>> [ class-and ] when* ] reduce
|
||||
<class-info>
|
||||
] bi
|
||||
refine-value-info ;
|
||||
} cond [ object <class-info> ] unless* ;
|
||||
|
|
|
@ -16,7 +16,7 @@ TUPLE: #introduce < node value ;
|
|||
: #introduce ( value -- node )
|
||||
\ #introduce new swap >>value ;
|
||||
|
||||
TUPLE: #call < node word history in-d out-d ;
|
||||
TUPLE: #call < node word in-d out-d body method ;
|
||||
|
||||
: #call ( inputs outputs word -- node )
|
||||
\ #call new
|
||||
|
@ -70,7 +70,7 @@ TUPLE: #terminate < node in-d ;
|
|||
\ #terminate new
|
||||
swap >>in-d ;
|
||||
|
||||
TUPLE: #branch < node in-d children ;
|
||||
TUPLE: #branch < node in-d children live-branches ;
|
||||
|
||||
: new-branch ( value children class -- node )
|
||||
new
|
||||
|
@ -140,6 +140,8 @@ TUPLE: #copy < node in-d out-d ;
|
|||
swap >>out-d
|
||||
swap >>in-d ;
|
||||
|
||||
: in/out ( node -- in-d out-d ) [ in-d>> ] [ out-d>> ] bi ; inline
|
||||
|
||||
: node, ( node -- ) stack-visitor get push ;
|
||||
|
||||
M: vector child-visitor V{ } clone ;
|
||||
|
|
|
@ -12,10 +12,13 @@ IN: stack-checker.branches
|
|||
: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
|
||||
dup [ [ - f <repetition> ] dip append ] [ 3drop f ] if ;
|
||||
|
||||
: pad-with-f ( seq -- newseq )
|
||||
dup [ length ] map supremum '[ , f pad-left ] map ;
|
||||
|
||||
: phi-inputs ( max-d-in pairs -- newseq )
|
||||
dup empty? [ nip ] [
|
||||
swap '[ , _ first2 unify-inputs ] map
|
||||
dup [ length ] map supremum '[ , f pad-left ] map
|
||||
pad-with-f
|
||||
flip
|
||||
] if ;
|
||||
|
||||
|
|
|
@ -20,9 +20,7 @@ IN: stack-checker.inlining
|
|||
TUPLE: inline-recursive word enter-out return calls fixed-point introductions ;
|
||||
|
||||
: <inline-recursive> ( word -- label )
|
||||
inline-recursive new
|
||||
swap >>word
|
||||
V{ } clone >>calls ;
|
||||
inline-recursive new swap >>word ;
|
||||
|
||||
: quotation-param? ( obj -- ? )
|
||||
dup pair? [ second effect? ] [ drop f ] if ;
|
||||
|
|
Loading…
Reference in New Issue