diff --git a/unfinished/compiler/tree/combinators/combinators.factor b/unfinished/compiler/tree/combinators/combinators.factor index 3adce27b43..05f5cf4daa 100644 --- a/unfinished/compiler/tree/combinators/combinators.factor +++ b/unfinished/compiler/tree/combinators/combinators.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry kernel accessors sequences sequences.deep arrays -compiler.tree ; +stack-checker.inlining namespaces compiler.tree ; IN: compiler.tree.combinators : each-node ( nodes quot: ( node -- ) -- ) @@ -50,3 +50,8 @@ IN: compiler.tree.combinators : 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline : 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline + +: until-fixed-point ( #recursive quot -- ) + over label>> t >>fixed-point drop + [ with-scope ] 2keep + over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ; inline diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor new file mode 100644 index 0000000000..7600a3b5a2 --- /dev/null +++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs namespaces sequences kernel math +stack-checker.state compiler.tree.copy-equiv ; +IN: compiler.tree.escape-analysis.allocations + +SYMBOL: escaping + +! A map from values to sequences of values or 'escaping' +SYMBOL: allocations + +: allocation ( value -- allocation ) + resolve-copy allocations get at ; + +: record-allocation ( allocation value -- ) + allocations get set-at ; + +: record-allocations ( allocations values -- ) + [ record-allocation ] 2each ; + +: record-slot-access ( out slot# in -- ) + over zero? [ 3drop ] [ allocation ?nth swap is-copy-of ] if ; + +! A map from values to sequences of values +SYMBOL: slot-merging + +: merge-slots ( values -- value ) + [ introduce-value ] [ slot-merging get set-at ] [ ] tri ; diff --git a/unfinished/compiler/tree/escape-analysis/branches/branches.factor b/unfinished/compiler/tree/escape-analysis/branches/branches.factor new file mode 100644 index 0000000000..23e53fd4fe --- /dev/null +++ b/unfinished/compiler/tree/escape-analysis/branches/branches.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel namespaces sequences +compiler.tree +compiler.tree.propagation.branches +compiler.tree.escape-analysis.nodes +compiler.tree.escape-analysis.allocations ; +IN: compiler.tree.escape-analysis.branches + +SYMBOL: children-escape-data + +M: #branch escape-analysis* + live-children sift [ (escape-analysis) ] each ; + +: (merge-allocations) ( values -- allocation ) + [ + [ allocation ] map dup [ ] all? [ + dup [ length ] map all-equal? [ + flip + [ (merge-allocations) ] [ [ merge-slots ] map ] bi + [ record-allocations ] keep + ] [ drop f ] if + ] [ drop f ] if + ] map ; + +: merge-allocations ( in-values out-values -- ) + [ (merge-allocations) ] dip record-allocations ; + +M: #phi escape-analysis* + [ [ phi-in-d>> ] [ out-d>> ] bi merge-allocations ] + [ [ phi-in-r>> ] [ out-r>> ] bi merge-allocations ] + bi ; diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor new file mode 100644 index 0000000000..490fff82ec --- /dev/null +++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces search-dequeues +compiler.tree +compiler.tree.def-use +compiler.tree.escape-analysis.allocations +compiler.tree.escape-analysis.recursive +compiler.tree.escape-analysis.branches +compiler.tree.escape-analysis.nodes +compiler.tree.escape-analysis.simple +compiler.tree.escape-analysis.work-list ; +IN: compiler.tree.escape-analysis + +: escape-analysis ( node -- node ) + H{ } clone slot-merging set + H{ } clone allocations set + work-list set + dup (escape-analysis) ; diff --git a/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor b/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor new file mode 100644 index 0000000000..eb56a9e338 --- /dev/null +++ b/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences compiler.tree ; +IN: compiler.tree.escape-analysis.nodes + +GENERIC: escape-analysis* ( node -- ) + +M: node escape-analysis* drop ; + +: (escape-analysis) ( node -- ) [ escape-analysis* ] each ; diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor new file mode 100644 index 0000000000..89ff2e59b4 --- /dev/null +++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor @@ -0,0 +1,16 @@ +IN: compiler.tree.escape-analysis.recursive.tests +USING: kernel tools.test namespaces sequences +compiler.tree.copy-equiv +compiler.tree.escape-analysis.recursive +compiler.tree.escape-analysis.allocations ; + +H{ } clone allocations set +H{ } clone copies set + +[ ] [ 8 [ introduce-value ] each ] unit-test + +[ ] [ { 1 2 } 3 record-allocation ] unit-test + +[ t ] [ { 1 2 } { 6 7 } congruent? ] unit-test +[ f ] [ { 3 4 } { 6 7 } congruent? ] unit-test +[ f ] [ { 3 4 5 } { 6 7 } congruent? ] unit-test diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor new file mode 100644 index 0000000000..f0f49ee083 --- /dev/null +++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences math combinators accessors namespaces +compiler.tree +compiler.tree.copy-equiv +compiler.tree.combinators +compiler.tree.escape-analysis.nodes +compiler.tree.escape-analysis.branches +compiler.tree.escape-analysis.allocations ; +IN: compiler.tree.escape-analysis.recursive + +: congruent? ( alloc1 alloc2 -- ? ) + 2dup [ length ] bi@ = [ + [ [ allocation ] bi@ congruent? ] 2all? + ] [ 2drop f ] if ; + +: check-fixed-point ( node alloc1 alloc2 -- node ) + congruent? [ dup label>> f >>fixed-point drop ] unless ; inline + +: node-input-allocations ( node -- allocations ) + in-d>> [ allocation ] map ; + +: node-output-allocations ( node -- allocations ) + out-d>> [ allocation ] map ; + +: recursive-stacks ( #enter-recursive -- stacks ) + [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ; + +: analyze-recursive-phi ( #enter-recursive -- ) + [ ] [ recursive-stacks flip (merge-allocations) ] [ out-d>> ] tri + [ [ allocation ] map check-fixed-point drop ] 2keep + record-allocations ; + +M: #recursive escape-analysis* ( #recursive -- ) + [ + copies [ clone ] change + + child>> + [ first analyze-recursive-phi ] + [ (escape-analysis) ] + bi + ] until-fixed-point ; + +M: #call-recursive escape-analysis* ( #call-label -- ) + dup + [ node-output-allocations ] + [ label>> return>> node-input-allocations ] bi + [ check-fixed-point ] keep + swap out-d>> record-allocations ; + +! M: #return-recursive escape-analysis* ( #return-recursive -- ) +! dup dup label>> calls>> dup empty? [ 3drop ] [ +! [ node-input-allocations ] +! [ first node-output-allocations ] bi* +! check-fixed-point drop +! ] if ; diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor new file mode 100644 index 0000000000..cc6ac57a5e --- /dev/null +++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences classes.tuple +classes.tuple.private math math.private slots.private +combinators dequeues search-dequeues namespaces fry +compiler.tree +compiler.tree.propagation.info +compiler.tree.escape-analysis.nodes +compiler.tree.escape-analysis.work-list +compiler.tree.escape-analysis.allocations ; +IN: compiler.tree.escape-analysis.simple + +: record-tuple-allocation ( #call -- ) + #! Delegation. + dup dup in-d>> peek node-value-info literal>> + class>> all-slots rest-slice [ read-only>> ] all? [ + [ in-d>> but-last ] [ out-d>> first ] bi + record-allocation + ] [ drop ] if ; + +: record-slot-call ( #call -- ) + [ out-d>> first ] + [ dup in-d>> second node-value-info literal>> ] + [ in-d>> first ] tri + over fixnum? [ [ 3 - ] dip record-slot-access ] [ 3drop ] if ; + +M: #call escape-analysis* + dup word>> { + { \ [ record-tuple-allocation ] } + { \ slot [ record-slot-call ] } + [ drop in-d>> add-escaping-values ] + } case ; + +M: #return escape-analysis* + in-d>> add-escaping-values ; diff --git a/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor b/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor new file mode 100644 index 0000000000..8378ee43ae --- /dev/null +++ b/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: dequeues namespaces sequences fry ; +IN: compiler.tree.escape-analysis.work-list + +SYMBOL: work-list + +: add-escaping-values ( values -- ) + work-list get '[ , push-front ] each ; diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor index bba920949b..535fddb93b 100644 --- a/unfinished/compiler/tree/propagation/branches/branches.factor +++ b/unfinished/compiler/tree/propagation/branches/branches.factor @@ -43,18 +43,17 @@ SYMBOL: infer-children-data value-infos [ clone ] change constraints [ clone ] change ; +: no-value-info ( -- ) + value-infos off + constraints off ; + : infer-children ( node -- ) [ live-children ] [ child-constraints ] bi [ [ - over [ - copy-value-info - assume - (propagate) - ] [ - 2drop - value-infos off - constraints off - ] if + over + [ copy-value-info assume (propagate) ] + [ 2drop no-value-info ] + if ] H{ } make-assoc ] 2map infer-children-data set ; diff --git a/unfinished/compiler/tree/propagation/inlining/inlining.factor b/unfinished/compiler/tree/propagation/inlining/inlining.factor index 1182d8211f..e4da863d68 100644 --- a/unfinished/compiler/tree/propagation/inlining/inlining.factor +++ b/unfinished/compiler/tree/propagation/inlining/inlining.factor @@ -142,3 +142,8 @@ SYMBOL: history : inline-method-body ( #call word -- ? ) 2dup should-inline? [ inline-word t ] [ 2drop f ] if ; + +: always-inline-word? ( word -- ? ) + { curry compose } memq? ; + +: always-inline-word ( #call word -- ? ) inline-word t ; diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 0036f7bcc1..b14e94ab8c 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -325,7 +325,7 @@ cell-bits 32 = [ [ V{ t } ] [ [ [ 1 f ] [ 2 f ] if length 3 < ] final-literals ] unit-test [ V{ 10 } ] [ - [ { fixnum } declare dup 10 = [ "A" throw ] unless ] final-literals + [ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals ] unit-test ! Slot propagation diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index c5fb04e322..3732d7c08c 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors arrays fry math.intervals -combinators +combinators namespaces stack-checker.inlining compiler.tree compiler.tree.copy-equiv +compiler.tree.combinators compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.propagation.simple @@ -48,28 +49,20 @@ IN: compiler.tree.propagation.recursive [ node-output-infos check-fixed-point drop ] 2keep out-d>> set-value-infos ; -USING: namespaces math ; -SYMBOL: iter-counter -0 iter-counter set-global M: #recursive propagate-around ( #recursive -- ) - iter-counter inc - iter-counter get 10 > [ "Oops" throw ] when - dup label>> t >>fixed-point drop [ - [ - copies [ clone ] change - constraints [ clone ] change + [ + copies [ clone ] change + constraints [ clone ] change - child>> - [ first propagate-recursive-phi ] - [ (propagate) ] - bi - ] with-scope - ] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ; + child>> + [ first propagate-recursive-phi ] + [ (propagate) ] + bi + ] until-fixed-point ; : generalize-return-interval ( info -- info' ) - dup [ literal?>> ] [ class>> null-class? ] bi or [ - clone [-inf,inf] >>interval - ] unless ; + dup [ literal?>> ] [ class>> null-class? ] bi or + [ clone [-inf,inf] >>interval ] unless ; : generalize-return ( infos -- infos' ) [ generalize-return-interval ] map ; diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor index 589ad6db4c..4237738625 100644 --- a/unfinished/compiler/tree/propagation/simple/simple.factor +++ b/unfinished/compiler/tree/propagation/simple/simple.factor @@ -94,6 +94,7 @@ M: #declare propagate-before : do-inlining ( #call word -- ? ) { + { [ dup always-inline-word? ] [ always-inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } { [ dup math-partial? ] [ inline-math-partial ] } diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor index 2924eb4369..5e3480be2f 100644 --- a/unfinished/compiler/tree/propagation/slots/slots.factor +++ b/unfinished/compiler/tree/propagation/slots/slots.factor @@ -29,7 +29,7 @@ UNION: fixed-length-sequence array byte-array string ; bi* value-info-intersect 1array ; : tuple-constructor? ( word -- ? ) - { curry compose } memq? ; + { } memq? ; : read-only-slots ( values class -- slots ) #! Delegation. @@ -54,20 +54,12 @@ UNION: fixed-length-sequence array byte-array string ; in-d>> unclip-last value-info literal>> class>> (propagate-tuple-constructor) ; -: propagate-curry ( #call -- info ) - in-d>> \ curry (propagate-tuple-constructor) ; - -: propagate-compose ( #call -- info ) - in-d>> \ compose (propagate-tuple-constructor) ; - : propagate- ( #call -- info ) in-d>> [ value-info ] map complex ; : propagate-tuple-constructor ( #call word -- infos ) { { \ [ propagate- ] } - { \ curry [ propagate-curry ] } - { \ compose [ propagate-compose ] } { \ [ propagate- ] } } case 1array ;