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

DCE work in progress

db4
Slava Pestov 2008-08-13 14:17:04 -05:00
parent 75c17dfa8a
commit 4f82ebdc23
15 changed files with 147 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
basis/compiler/compiler.factor
View File

@ -46,6 +46,7 @@ SYMBOL: +failed+
] tri ;
: (compile) ( word -- )
USE: prettyprint dup .
[
H{ } clone dependencies set

1
basis/compiler/generator/generator.factor
View File

@ -152,6 +152,7 @@ M: #if generate-node
%save-dispatch-xt
%prologue-later
[ generate-nodes ] with-node-iterator
%return
] with-generator
] keep ;

16
basis/compiler/generator/iterator/iterator.factor
View File

@ -28,14 +28,18 @@ DEFER: (tail-call?)
[ value #phi? ] [ next (tail-call?) ] bi and ;
: (tail-call?) ( cursor -- ? )
[ value [ #return? ] [ #terminate? ] bi or ]
[ tail-phi? ]
bi or ;
dup [
[ value [ #return? ] [ #terminate? ] bi or ]
[ tail-phi? ]
bi or
] [ drop t ] if ;
: tail-call? ( -- ? )
node-stack get [
next
[ (tail-call?) ]
[ value #terminate? not ]
bi and
dup [
[ (tail-call?) ]
[ value #terminate? not ]
bi and
] [ drop t ] if
] all? ;

2
basis/compiler/tree/checker/checker.factor
View File

@ -45,7 +45,7 @@ M: #phi check-node
M: #enter-recursive check-node
[ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
[ [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix check-lengths ]
[ recursive-phi-in check-lengths ]
bi ;
M: #push check-node

2
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -72,6 +72,8 @@ M: #call cleanup*
[ ]
} cond ;
M: #declare cleanup* drop f ;
GENERIC: delete-node ( node -- )
M: #call-recursive delete-node

33
basis/compiler/tree/dataflow-analysis/backward/backward.factor
View File

@ -9,37 +9,40 @@ GENERIC: backward ( value node -- )
M: #copy backward
#! If the output of a copy is live, then the corresponding
#! input is live also.
[ out-d>> index ] keep in-d>> nth look-at-value ;
[ out-d>> ] [ in-d>> ] bi look-at-mapping ;
M: #call backward
#! If any of the outputs of a call are live, then all
#! inputs and outputs must be live.
nip [ look-at-inputs ] [ look-at-outputs ] bi ;
M: #call backward nip look-at-inputs ;
M: #call-recursive backward
#! If the output of a copy is live, then the corresponding
#! inputs to #return nodes are live also.
[ out-d>> <reversed> index ] keep label>> returns>>
[ <reversed> nth look-at-value ] with each ;
[ out-d>> ] [ label>> return>> ] bi look-at-mapping ;
M: #>r backward nip in-d>> first look-at-value ;
M: #>r backward [ out-r>> ] [ in-d>> ] bi look-at-mapping ;
M: #r> backward nip in-r>> first look-at-value ;
M: #r> backward [ out-d>> ] [ in-r>> ] bi look-at-mapping ;
M: #shuffle backward mapping>> at look-at-value ;
M: #phi backward
#! If any of the outputs of a #phi are live, then the
#! corresponding inputs are live too.
[ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
[ [ out-d>> ] [ phi-in-d>> ] bi look-at-phi ]
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-phi ]
2bi ;
M: #alien-invoke backward
nip [ look-at-inputs ] [ look-at-outputs ] bi ;
M: #enter-recursive backward
[ out-d>> ] [ recursive-phi-in flip ] bi look-at-phi ;
M: #alien-indirect backward
nip [ look-at-inputs ] [ look-at-outputs ] bi ;
: return-recursive-phi-in ( #return-recursive -- phi-in )
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
M: #return-recursive backward
[ out-d>> ] [ return-recursive-phi-in flip ] bi look-at-phi ;
M: #alien-invoke backward nip look-at-inputs ;
M: #alien-indirect backward nip look-at-inputs ;
M: node backward 2drop ;

5
basis/compiler/tree/dataflow-analysis/dataflow-analysis.factor
View File

@ -15,9 +15,10 @@ SYMBOL: work-list
: look-at-inputs ( node -- ) in-d>> look-at-values ;
: look-at-outputs ( node -- ) out-d>> look-at-values ;
: look-at-mapping ( value inputs outputs -- )
[ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
: look-at-corresponding ( value inputs outputs -- )
: look-at-phi ( value inputs outputs -- )
[ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
: init-dfa ( -- )

16
basis/compiler/tree/dead-code/dead-code-tests.factor
View File

@ -1,13 +1,15 @@
USING: namespaces assocs sequences compiler.tree.builder
compiler.tree.dead-code compiler.tree.def-use compiler.tree
compiler.tree.combinators tools.test kernel math
stack-checker.state accessors combinators ;
compiler.tree.combinators compiler.tree.debugger
compiler.tree.normalization tools.test
kernel math stack-checker.state accessors combinators io ;
IN: compiler.tree.dead-code.tests
\ remove-dead-code must-infer
: count-live-values ( quot -- n )
build-tree
normalize
compute-def-use
remove-dead-code
0 swap [
@ -51,3 +53,13 @@ IN: compiler.tree.dead-code.tests
[ 2 ] [ [ [ 1 ] [ 2 ] compose call ] count-live-values ] unit-test
[ 0 ] [ [ [ 1 ] [ 2 ] compose call + drop ] count-live-values ] unit-test
: optimize-quot ( quot -- quot' )
build-tree normalize compute-def-use remove-dead-code
nodes>quot ;
[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test
[ [ read 1 2 ] ] [ [ read >r 1 2 r> drop ] optimize-quot ] unit-test
[ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test

180
basis/compiler/tree/dead-code/dead-code.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors namespaces assocs dequeues search-dequeues
kernel sequences words sets stack-checker.inlining
kernel sequences words sets arrays
stack-checker.state stack-checker.inlining
compiler.tree
compiler.tree.combinators
compiler.tree.dataflow-analysis
@ -12,25 +13,19 @@ IN: compiler.tree.dead-code
! outputs are unused using backward DFA.
GENERIC: mark-live-values ( node -- )
M: #introduce mark-live-values
value>> look-at-value ;
M: #if mark-live-values look-at-inputs ;
M: #dispatch mark-live-values look-at-inputs ;
M: #call mark-live-values
dup word>> "flushable" word-prop
[ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
[ drop ] [ look-at-inputs ] if ;
M: #alien-invoke mark-live-values
[ look-at-inputs ] [ look-at-outputs ] bi ;
M: #alien-invoke mark-live-values look-at-inputs ;
M: #alien-indirect mark-live-values
[ look-at-inputs ] [ look-at-outputs ] bi ;
M: #alien-indirect mark-live-values look-at-inputs ;
M: #return mark-live-values
look-at-inputs ;
M: #return mark-live-values look-at-inputs ;
M: node mark-live-values drop ;
@ -38,70 +33,80 @@ SYMBOL: live-values
: live-value? ( value -- ? ) live-values get at ;
: compute-live-values ( node -- )
[ mark-live-values ] backward-dfa live-values set ;
GENERIC: remove-dead-code* ( node -- node' )
GENERIC: remove-dead-values* ( node -- )
M: #>r remove-dead-values*
dup out-r>> first live-value? [ { } >>out-r ] unless
dup in-d>> first live-value? [ { } >>in-d ] unless
drop ;
M: #r> remove-dead-values*
dup out-d>> first live-value? [ { } >>out-d ] unless
dup in-r>> first live-value? [ { } >>in-r ] unless
drop ;
M: #push remove-dead-values*
dup out-d>> first live-value? [ { } >>out-d ] unless
drop ;
: filter-corresponding-values ( in out -- in' out' )
zip live-values get '[ drop _ , key? ] assoc-filter unzip ;
M: #introduce remove-dead-code*
dup value>> live-value? [
dup value>> 1array #drop 2array
] unless ;
: filter-live ( values -- values' )
[ live-value? ] filter ;
M: #call remove-dead-values*
M: #>r remove-dead-code*
[ filter-live ] change-out-r
[ filter-live ] change-in-d
dup in-d>> empty? [ drop f ] when ;
M: #r> remove-dead-code*
[ filter-live ] change-out-d
[ filter-live ] change-in-r
dup in-r>> empty? [ drop f ] when ;
M: #push remove-dead-code*
dup out-d>> first live-value? [ drop f ] unless ;
: dead-flushable-call? ( #call -- ? )
[ word>> "flushable" word-prop ]
[ out-d>> [ live-value? not ] all? ] bi and ;
: remove-flushable-call ( #call -- node )
in-d>> #drop remove-dead-code* ;
: some-outputs-dead? ( #call -- ? )
out-d>> [ live-value? not ] contains? ;
: remove-dead-outputs ( #call -- nodes )
[ out-d>> ] [ [ [ <value> ] replicate ] change-out-d ] bi
[ nip ] [ out-d>> swap #copy remove-dead-code* ] 2bi
2array ;
M: #call remove-dead-code*
dup dead-flushable-call? [
remove-flushable-call
] [
dup some-outputs-dead? [
remove-dead-outputs
] when
] if ;
M: #recursive remove-dead-code*
[ filter-live ] change-in-d ;
M: #call-recursive remove-dead-code*
[ filter-live ] change-in-d
[ filter-live ] change-out-d ;
M: #enter-recursive remove-dead-code*
[ filter-live ] change-in-d
[ filter-live ] change-out-d ;
M: #return-recursive remove-dead-code*
[ filter-live ] change-in-d
[ filter-live ] change-out-d ;
M: #shuffle remove-dead-code*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
drop ;
dup in-d>> empty? [ drop f ] when ;
M: #recursive remove-dead-values*
[ filter-live ] change-in-d
drop ;
M: #call-recursive remove-dead-values*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
drop ;
M: #enter-recursive remove-dead-values*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
drop ;
M: #return-recursive remove-dead-values*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
drop ;
M: #shuffle remove-dead-values*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
drop ;
M: #declare remove-dead-values*
[ [ drop live-value? ] assoc-filter ] change-declaration
drop ;
M: #copy remove-dead-values*
dup
M: #copy remove-dead-code*
[ in-d>> ] [ out-d>> ] bi
filter-corresponding-values
[ >>in-d ] [ >>out-d ] bi*
drop ;
2dup swap zip #shuffle
remove-dead-code* ;
: filter-corresponding-values ( in out -- in' out' )
zip live-values get '[ drop _ , key? ] assoc-filter unzip ;
: remove-dead-phi-d ( #phi -- #phi )
dup
@ -115,44 +120,13 @@ M: #copy remove-dead-values*
filter-corresponding-values
[ >>phi-in-r ] [ >>out-r ] bi* ;
M: #phi remove-dead-values*
M: #phi remove-dead-code*
remove-dead-phi-d
remove-dead-phi-r
drop ;
remove-dead-phi-r ;
M: node remove-dead-values* drop ;
: remove-dead-values ( nodes -- )
[ remove-dead-values* ] each-node ;
GENERIC: remove-dead-nodes* ( node -- node/f )
: prune-if-empty ( node seq -- node/f )
empty? [ drop f ] when ; inline
: live-call? ( #call -- ? ) out-d>> [ live-value? ] contains? ;
M: #declare remove-dead-nodes* dup declaration>> prune-if-empty ;
M: #call remove-dead-nodes* dup live-call? [ in-d>> #drop ] unless ;
M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
M: #push remove-dead-nodes* dup out-d>> prune-if-empty ;
M: #>r remove-dead-nodes* dup in-d>> prune-if-empty ;
M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
M: node remove-dead-nodes* ;
: remove-dead-nodes ( nodes -- nodes' )
[ remove-dead-nodes* ] map-nodes ;
M: node remove-dead-code* ;
: remove-dead-code ( node -- newnode )
[ compute-live-values ]
[ remove-dead-values ]
[ remove-dead-nodes ]
tri ;
[ [ mark-live-values ] backward-dfa live-values set ]
[ [ remove-dead-code* ] map-nodes ]
bi ;

18
basis/compiler/tree/debugger/debugger.factor
View File

@ -46,13 +46,13 @@ MATCH-VARS: ?a ?b ?c ;
{ _ f }
} match-choose ;
TUPLE: shuffle effect ;
M: shuffle pprint* effect>> effect>string text ;
TUPLE: shuffle-node effect ;
M: shuffle-node pprint* effect>> effect>string text ;
M: #shuffle node>quot
shuffle-effect dup pretty-shuffle
[ % ] [ shuffle boa , ] ?if ;
[ % ] [ shuffle-node boa , ] ?if ;
: pushed-literals ( node -- seq )
dup out-d>> [ node-value-info literal>> literalize ] with map ;
@ -78,9 +78,15 @@ M: #if node>quot
M: #dispatch node>quot
children>> [ nodes>quot ] map , \ dispatch , ;
M: #>r node>quot in-d>> length \ >r <repetition> % ;
M: #>r node>quot
[ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi
<repetition> % ;
M: #r> node>quot out-d>> length \ r> <repetition> % ;
DEFER: rdrop
M: #r> node>quot
[ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
<repetition> % ;
M: node node>quot drop ;

2
basis/compiler/tree/escape-analysis/allocations/allocations.factor
View File

@ -57,7 +57,7 @@ SYMBOL: +escaping+
<value> dup introduce-value ;
: merge-values ( in-values out-value -- )
escaping-values get '[ , , equate ] each ;
escaping-values get equate-all-with ;
: merge-slots ( values -- value )
<slot-value> [ merge-values ] keep ;

2
basis/compiler/tree/escape-analysis/recursive/recursive.factor
View File

@ -27,7 +27,7 @@ IN: compiler.tree.escape-analysis.recursive
out-d>> [ allocation ] map ;
: recursive-stacks ( #enter-recursive -- stacks )
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix
recursive-phi-in
escaping-values get '[ [ , disjoint-set-member? ] all? ] filter
flip ;

2
basis/compiler/tree/escape-analysis/simple/simple.factor
View File

@ -11,8 +11,6 @@ compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.simple
M: #declare escape-analysis* drop ;
M: #terminate escape-analysis* drop ;
M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ;

3
basis/compiler/tree/intrinsics/intrinsics.factor
View File

@ -4,8 +4,7 @@ USING: kernel classes.tuple classes.tuple.private math arrays
byte-arrays words stack-checker.known-words ;
IN: compiler.tree.intrinsics
: <immutable-tuple-boa> ( ... class -- tuple )
"BUG: missing <immutable-tuple-boa> intrinsic" throw ;
: <immutable-tuple-boa> ( ... class -- tuple ) <tuple-boa> ;
: (tuple) ( layout -- tuple )
"BUG: missing (tuple) intrinsic" throw ;

7
basis/compiler/tree/tree.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel math namespaces parser
USING: fry arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes
accessors combinators stack-checker.state stack-checker.visitor ;
IN: compiler.tree
@ -179,9 +179,12 @@ M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
: shuffle-effect ( #shuffle -- effect )
[ in-d>> ] [ out-d>> ] [ mapping>> ] tri
[ at ] curry map
'[ , at ] map
<effect> ;
: recursive-phi-in ( #enter-recursive -- seq )
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
M: vector child-visitor V{ } clone ;
M: vector #introduce, #introduce node, ;
M: vector #call, #call node, ;