diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index a15c5b9b8f..5880d05e93 100755 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -46,6 +46,7 @@ SYMBOL: +failed+ ] tri ; : (compile) ( word -- ) + USE: prettyprint dup . [ H{ } clone dependencies set diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index aa9b6769ee..ddfbae35a9 100755 --- a/basis/compiler/generator/generator.factor +++ b/basis/compiler/generator/generator.factor @@ -152,6 +152,7 @@ M: #if generate-node %save-dispatch-xt %prologue-later [ generate-nodes ] with-node-iterator + %return ] with-generator ] keep ; diff --git a/basis/compiler/generator/iterator/iterator.factor b/basis/compiler/generator/iterator/iterator.factor index 68881990be..1654ea515c 100644 --- a/basis/compiler/generator/iterator/iterator.factor +++ b/basis/compiler/generator/iterator/iterator.factor @@ -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? ; diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index 08beec8b8f..8f60867148 100644 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -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 diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 1ea31fe815..3a0cc473bc 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -72,6 +72,8 @@ M: #call cleanup* [ ] } cond ; +M: #declare cleanup* drop f ; + GENERIC: delete-node ( node -- ) M: #call-recursive delete-node diff --git a/basis/compiler/tree/dataflow-analysis/backward/backward.factor b/basis/compiler/tree/dataflow-analysis/backward/backward.factor index d69202c7ad..59bfac0725 100644 --- a/basis/compiler/tree/dataflow-analysis/backward/backward.factor +++ b/basis/compiler/tree/dataflow-analysis/backward/backward.factor @@ -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>> index ] keep label>> returns>> - [ 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 ; diff --git a/basis/compiler/tree/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/tree/dataflow-analysis/dataflow-analysis.factor index 54b10e9612..775e3b345c 100644 --- a/basis/compiler/tree/dataflow-analysis/dataflow-analysis.factor +++ b/basis/compiler/tree/dataflow-analysis/dataflow-analysis.factor @@ -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 ( -- ) diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index 7b0919562f..1995c45976 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -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 diff --git a/basis/compiler/tree/dead-code/dead-code.factor b/basis/compiler/tree/dead-code/dead-code.factor index 652fa19af3..11d3cd227b 100644 --- a/basis/compiler/tree/dead-code/dead-code.factor +++ b/basis/compiler/tree/dead-code/dead-code.factor @@ -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>> ] [ [ [ ] 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 ; diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index c541311ef2..b3f832e198 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -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 % ; +M: #>r node>quot + [ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi + % ; -M: #r> node>quot out-d>> length \ r> % ; +DEFER: rdrop + +M: #r> node>quot + [ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi + % ; M: node node>quot drop ; diff --git a/basis/compiler/tree/escape-analysis/allocations/allocations.factor b/basis/compiler/tree/escape-analysis/allocations/allocations.factor index 2296afebc4..100ced5acd 100644 --- a/basis/compiler/tree/escape-analysis/allocations/allocations.factor +++ b/basis/compiler/tree/escape-analysis/allocations/allocations.factor @@ -57,7 +57,7 @@ SYMBOL: +escaping+ dup introduce-value ; : merge-values ( in-values out-value -- ) - escaping-values get '[ , , equate ] each ; + escaping-values get equate-all-with ; : merge-slots ( values -- value ) [ merge-values ] keep ; diff --git a/basis/compiler/tree/escape-analysis/recursive/recursive.factor b/basis/compiler/tree/escape-analysis/recursive/recursive.factor index 1ea89787df..d1a7bf3aa6 100644 --- a/basis/compiler/tree/escape-analysis/recursive/recursive.factor +++ b/basis/compiler/tree/escape-analysis/recursive/recursive.factor @@ -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 ; diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index af42dc5145..b10e108403 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/basis/compiler/tree/escape-analysis/simple/simple.factor @@ -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 ; diff --git a/basis/compiler/tree/intrinsics/intrinsics.factor b/basis/compiler/tree/intrinsics/intrinsics.factor index 322e0dabe1..0d8ff5b833 100644 --- a/basis/compiler/tree/intrinsics/intrinsics.factor +++ b/basis/compiler/tree/intrinsics/intrinsics.factor @@ -4,8 +4,7 @@ USING: kernel classes.tuple classes.tuple.private math arrays byte-arrays words stack-checker.known-words ; IN: compiler.tree.intrinsics -: ( ... class -- tuple ) - "BUG: missing intrinsic" throw ; +: ( ... class -- tuple ) ; : (tuple) ( layout -- tuple ) "BUG: missing (tuple) intrinsic" throw ; diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 175c1ddfdd..58013e6c77 100755 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -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 ; +: 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, ;